以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.net/bbs/index.asp)
--  专家坐堂  (http://foxtable.net/bbs/list.asp?boardid=2)
----  excel报表问题  (http://foxtable.net/bbs/dispbbs.asp?boardid=2&id=105340)

--  作者:rjh4078
--  发布时间:2017/8/17 11:16:00
--  excel报表问题
如果文字超过单元格 如何让单元格自适应文字大小?
--  作者:有点甜
--  发布时间:2017/8/17 11:37:00
--  

 生成以后,用vba处理下。

 

 

Dim Book As New XLS.Book(ProjectPath & "Attachments\\订单计划一览表.xls")
Dim fl As String = ProjectPath & "Reports\\订单计划一览表.xls"
Dim Sheet As XLS.Sheet = Book.Sheets(0) \'引用工作簿的第一个工作表
Book.Build() \'生成细节区

Book.Save(fl) \'保存工作簿


Dim App As New MSExcel.Application
Dim Wb As MSExcel.WorkBook = App.WorkBooks.Open(fl)
Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1)
Dim Rg As MSExcel.Range = Ws.UsedRange
Rg.WrapText = True
\'Rg.EntireColumn.AutoFit   \'自动调整列宽
Rg.EntireRow.AutoFit  \'自动调整行高
App.Visible = True

[此贴子已经被作者于2017/8/17 11:38:18编辑过]

--  作者:rjh4078
--  发布时间:2017/8/17 17:12:00
--  
谢谢 马上测试
--  作者:rjh4078
--  发布时间:2017/8/17 17:21:00
--  
用这个代码以后 所有格式都没有了  而且关键的数据区也没有自动调整行高  
--  作者:rjh4078
--  发布时间:2017/8/17 17:25:00
--  

图片点击可在新窗口打开查看此主题相关图片如下:1.png
图片点击可在新窗口打开查看
这个是没有自动行高的代码生成的



这个是自动行高

图片点击可在新窗口打开查看此主题相关图片如下:2.png
图片点击可在新窗口打开查看


[此贴子已经被作者于2017/8/17 17:26:26编辑过]

--  作者:有点甜
--  发布时间:2017/8/17 17:31:00
--  
以下是引用rjh4078在2017/8/17 17:21:00的发言:
用这个代码以后 所有格式都没有了  而且关键的数据区也没有自动调整行高  

 

不可能影响你的样式。

 

如果你的单元格是合并的单元格要这样处理 http://www.foxtable.com/bbs/dispbbs.asp?BoardID=2&ID=70571&replyID=485270&skin=1

 


--  作者:有点甜
--  发布时间:2017/8/17 17:32:00
--  
 如果还有问题,实例发上来测试。
--  作者:rjh4078
--  发布时间:2017/8/17 17:35:00
--  
有没有办法在报表事件里对某个细节区的行高单独指定?
--  作者:rjh4078
--  发布时间:2017/8/17 18:12:00
--  
红色区域是一个子表数据生成区,如何将这个区域设置成自动行高

这个应该是单元格合并造成的,如果用2楼的代码就会将上面很多合并的单元格格式带歪,但是这个核心需求区域却不受影响。我参照下面这个代码做了修改 没有效果。
Dim App As New MSExcel.Application
try
    

            Dim Wb As MSExcel.WorkBook = App.WorkBooks.Open(ProjectPath & "reports\\工单.xls")
            Dim tempWs = wb.WorkSheets.Add
           \'\' For k As Integer = 1 To Wb.WorkSheets.Count - 1                
                Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1)
                Dim rg As MSExcel.Range
                For Each rg In ws.UsedRange
                    If rg.MergeCells Then
                        Dim tempCell As MSExcel.Range
                        Dim width As Double = 0
                        Dim tempCol
                        For Each tempcol In rg.MergeArea.Columns
                            width = width + tempcol.ColumnWidth
                        Next
                        tempWs.Columns(1).WrapText = True
                        tempWs.Columns(1).ColumnWidth = width
                        tempWs.Columns(1).Font.Size = rg.Font.Size
                        tempWs.Cells(1, 1).Value = rg.Value
                        tempWs.Cells(1, 1).RowHeight = 0
                        tempWs.Cells(1, 1).EntireRow.Activate
                        tempWs.Cells(1, 1).EntireRow.AutoFit
                        If (rg.RowHeight < tempWs.Cells(1, 1).RowHeight) Then
                            Dim tempHeight As Double
                            Dim tempCount As Integer
                            tempHeight = tempWs.Cells(1, 1).RowHeight
                            tempCount = rg.MergeArea.Rows.Count
                            For Each addHeightRow As object In rg.MergeArea.Rows
                                If (addHeightRow.RowHeight < tempHeight / tempCount) Then
                                    addHeightRow.RowHeight = tempHeight / tempCount
                                End If
                                tempHeight = tempHeight - addHeightRow.RowHeight
                                tempCount = tempCount - 1
                            Next
                            rg.WrapText = True
                        End If
                    End If
                Next
                
           \'\' Next
            app.DisplayAlerts = False
            tempWs.Delete
            Wb.Save
            
            \'Dim txt1 As WinForm.TextBox = Forms("翻译器").Controls("TextBox3")
            \'txt1.text = file & vbcrlf & txt1.text & vbcrlf
            Application.DoEvents()
           \'\' FileCount=FileCount+1
            
        
    
catch ex As exception
    msgbox(ex.message)
finally
    App.Quit()
End try
 下载信息  [文件大小:   下载次数: ]
图片点击可在新窗口打开查看点击浏览该文件:工单.xls


--  作者:有点甜
--  发布时间:2017/8/17 18:51:00
--  

限定范围即可。

 

Dim App As New MSExcel.Application
try
   
    Dim Wb As MSExcel.WorkBook = App.WorkBooks.Open("d:\\工单.xls")
    Dim Ws = wb.WorkSheets(1)
    Dim rg As MSExcel.Range
Dim tempWs = wb.WorkSheets.Add
    Dim tempCell As MSExcel.Range = tempWs.Cells(1, 1)
    For Each rg In ws.UsedRange
        If rg.MergeCells AndAlso rg.address.contains("$I") AndAlso rg.MergeArea.Columns.count=4 Then
            Dim width As Double = 0
            Dim tempCol
            For Each tempcol In rg.MergeArea.Columns
                width = width + tempcol.ColumnWidth
            Next
            tempWs.Columns(1).WrapText = True
            tempWs.Columns(1).ColumnWidth = width
            tempWs.Columns(1).Font.Size = rg.Font.Size
            tempcell.Value = rg.Value
            tempcell.RowHeight = 0
            tempcell.EntireRow.Activate
            tempcell.EntireRow.AutoFit
            If (rg.RowHeight < tempcell.RowHeight) Then
                Dim tempHeight As Double
                Dim tempCount As Integer
                tempHeight = tempcell.RowHeight
                tempCount = rg.MergeArea.Rows.Count
                For Each addHeightRow As object In rg.MergeArea.Rows
                   
                    If (addHeightRow.RowHeight < tempHeight / tempCount) Then
                        addHeightRow.RowHeight = tempHeight / tempCount
                    End If
                    tempHeight = tempHeight - addHeightRow.RowHeight
                    tempCount = tempCount - 1
                Next
                rg.WrapText = True
            End If
        End If
    Next
    app.DisplayAlerts = False
    tempWs.Delete
    app.visible = True
catch ex As exception
    msgbox(ex.message)
    app.quit
End try