怎樣設置導出execl自動調整列寬

Question

怎樣設置導出execl自動調整列寬；
With oSheet
        '.Range(.Cells(1, 1), .Cells(Irowcount, Icolcount)).
        '設表自動調整列寬
        .Range(.Cells(1, 1), .Cells(Irowcount, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
 End With

Answer 1

'自动调整栏宽
 dim mSelectin as object  
 Set mSelection = mSheet.Range("A" & CStr(nRow) & ":" & GetExcelCols(nCol) & CStr(nTolRows))
    With mSelection
        .Columns.AutoFit
        .Rows.AutoFit
    End WithPublic Function GetExcelCols(ByVal sCols As Integer) As String
    Dim sNum1 As Integer
    Dim sNum2 As Integer
    
    If sCols > 26 Then
        sNum1 = sCols \ 26
        sNum2 = sCols Mod 26
        If sNum2 = 0 Then '当为26的整数时
            GetExcelCols = Chr(64 + sNum1 - 1) & Chr(64 + 26)
        Else
            GetExcelCols = Chr(64 + sNum1) & Chr(64 + sNum2)
        End If
    Else
        GetExcelCols = Chr(64 + sCols)
    End If
End Function上面代码可以实现自动列宽，行高。
mSheet表示Sheet对象。
GetExcelCols表示依据列数返回对应列字符标识。

Answer 2

TKS!With oSheet
        .Range(.Columns("A"), .Columns("M")).AutoFit
        '設表自動調整列寬
        .Range(.Cells(1, 1), .Cells(Irowcount, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With

Answer 3

怎樣把以下代碼轉化成，
DataGrid1數據導出為Execl呢，
目前為Access數據導出為execl；Private Sub OutputToExcel_Click()
'2009.10.20 修改'Dim sNWind As StringDim conn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim xlsheet As Excel.Worksheet
Dim Irowcount As Integer            '數據的行數
Dim Icolcount As Integer            '數據的列數
'修改：把"絕對路徑"改成"相對路徑"'sNWind = "C:\Documents and Settings\goldenzhong\桌面\分析維修管理系統\information.mdb"'conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNWind & ";"conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\information.mdb;"
conn.CursorLocation = adUseClient
Set rs = conn.Execute("Info", , adCmdTable)
'在Excel中创建新的workbookDim oExcel As Object
Dim oBook As Object
Dim oSheet As Excel.Worksheet
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add
Set oSheet = oBook.Worksheets("Sheet1")'向 Excel中传输数据oSheet.Range("A1").CopyFromRecordset rs
'保存并退出Excel'修改原因：讓用戶選擇"保存路徑"及“文件名”？'2009.10.23 修改 打開變成另存為
'CommonDialog1.ShowOpen
CommonDialog1.ShowSave
'2009.10.22 修改  修改目的:導出execl表有標題
If rs.RecordCount > 0 Then
    '2009.10.24 修改 原因：rs.Fields.Count <>DataGrid1.Columns.Count
    'For i = 1 To rs.Fields.Count
    Icolcount = DataGrid1.Columns.Count
    Irowcount = rs.RecordCount    For i = 1 To DataGrid1.Columns.Count
        'oSheet.Cells(1, i) = rs.Fields(i - 1).Name
        oSheet.Cells(1, i) = DataGrid1.Columns(i - 1).Caption               '調用Datgrid1.Columns(i-1)字段名
    Next i
    
    With oSheet
        .Range(.Columns("A"), .Columns("M")).AutoFit
        '設表自動調整列寬
        .Range(.Cells(1, 1), .Cells(Irowcount, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With    
    'For i = 1 To rs.Fields.Count
        'oSheet.Cells(1, i).HorizontalAlignment = xlCenter
        'Range("A?").HorizontalAlignment = xlCenter
    'Next i
    
    oSheet.Columns("A:AC").HorizontalAlignment = xlCenter                   '所有行居中
    'CommonDialog1.Filter = "execl(*.xls)*.xls"
    'CommonDialog1.Filter = "*.xls"               ' 異常,直接CommonDialog1屬性Filter設置
    '如果保存文件名與保存文件夾中文件的文件名相同,將報錯(選擇"取消","否")
    If Len(CommonDialog1.FileName) > 3 Then
        oBook.SaveAs CommonDialog1.FileName
        MsgBox "導出Execl成功!", 0, "提示"
        oExcel.Quit
    End If
End If'oBook.SaveAs "C:\Documents and Settings\goldenzhong\桌面\Book1.xls"
'关闭连接rs.Close
conn.CloseEnd Sub

Answer 4

'把数据导入到Excel中rsDataRecordset:数据记录集,rsTitleRecordset:标题记录集
'P_Excel_Title:表示是否导出单据主档数据
'rsTitleData:表示主档明细资料记录集
'P_RowTitleCols:表示每行导出几列数据
'P_RowMergeCols:表示每行数据的多列之间空格列数
'P_NameCols:表示抬头中数据说明占用列数
'P_DataCols:表示抬头中数据占用列数
Public Sub ExportDataToExcel(ByVal rsDataRecordset As ADODB.Recordset, ByVal rsTitleRecordset As ADODB.Recordset, _
                             Optional ByVal mvarCaption As String, Optional ByVal P_Excel_Title As Boolean = False, _
                             Optional ByVal RsTitleData As ADODB.Recordset, Optional ByVal P_RowTitleCols As Integer = 2, _
                             Optional ByVal P_RowMergeCol As Integer = 1, Optional ByVal P_NameCols As Integer = 1, _
                             Optional ByVal P_DataCols As Integer = 1)
    Dim oExcel As Object
    Dim mWorkBook As Object
    Dim mSheet As Object
    Dim mRange As Object
    Dim nCol As Long
    Dim nRow As Long
    Dim nDetailPos As Integer
    Dim nTitleCols As Integer  '抬头列数
    Dim nTitleRows As Integer  '抬头行数
    Dim nRowCols As Integer    '每行列数
    Dim i As Integer
    Dim j As Integer
    Dim nCurCol As Integer     '当前列
    Dim nTolRows As Long       '总行数
    
    Set oExcel = CreateObject("Excel.Application")
    Set mWorkBook = oExcel.Workbooks.Add
    Set mSheet = mWorkBook.Sheets(1)
    '导入标题数据
    nCol = rsTitleRecordset.Fields.Count
    Set mRange = mSheet.Range("A1:" & GetExcelCols(nCol) & 1)
    mRange.Merge
    mRange.Value = mvarCaption
    mRange.Font.Size = 24
    mRange.HorizontalAlignment = &HFFFFEFF4
    '--表示从第二列开始
    nRow = 2
    '-表示需导出单据抬头数据
    If P_Excel_Title And Not (RsTitleData Is Nothing) Then
        nRow = 3
        nTitleCols = RsTitleData.Fields.Count
        nRowCols = P_RowTitleCols
        If nRowCols <= 0 Then nRowCols = 1
        nTitleRows = nTitleCols \ nRowCols + IIf(nTitleCols Mod nRowCols <> 0, 1, 0)
        For i = 1 To nTitleRows
            For j = 1 To nRowCols
                nCurCol = (j - 1) * ((P_NameCols + P_DataCols) + P_RowMergeCol) + 1
                '说明
                Set mRange = mSheet.Range(GetExcelCols(nCurCol) & CStr(nRow) & ":" & GetExcelCols(nCurCol + P_NameCols - 1) & CStr(nRow))
                '合并单元格
                mRange.Merge
                mRange.Value = RsTitleData.Fields((i - 1) * nRowCols + j - 1).Name
                mRange.HorizontalAlignment = &HFFFFEFDD
                '内容
                Set mRange = mSheet.Range(GetExcelCols(nCurCol + P_NameCols) & CStr(nRow) & ":" & GetExcelCols(nCurCol + P_NameCols + P_DataCols) & CStr(nRow))
                mRange.Merge
               mRange.Value = IIf(IsNull(RsTitleData.Fields((i - 1) * nRowCols + j - 1).Value), vbNull, RsTitleData.Fields((i - 1) * nRowCols + j - 1).Value)
                mRange.HorizontalAlignment = &HFFFFEFDD
            Next j
            nRow = nRow + 1
        Next i
    End If
    
    '--明细抬头
    Set mRange = mSheet.Range("A" & (nRow))
    mRange.CopyFromRecordset rsTitleRecordset
    '导入数据
    nDetailPos = rsTitleRecordset.RecordCount + nRow
    Set mRange = mSheet.Range("A" & nDetailPos)
    mRange.CopyFromRecordset rsDataRecordset
    rsDataRecordset.MoveLast
    nTolRows = rsTitleRecordset.RecordCount + rsDataRecordset.RecordCount + nRow - 1
    Set mRange = mSheet.Range("A" & CStr(nRow) & ":" & GetExcelCols(nCol) & CStr(nTolRows))
    mRange.Borders.LineStyle = 7
    mRange.Borders.Color = RGB(0, 0, 255)
    mRange.HorizontalAlignment = &HFFFFEFDD
    mRange.NumberFormatLocal = "@"
    '设定题头的对　方式
    Dim mSelection As Object
    Set mSelection = mSheet.Range("A" & CStr(nRow) & ":" & GetExcelCols(nCol) & nDetailPos - 1)
    With mSelection
        .HorizontalAlignment = &HFFFFEFF4
        .VerticalAlignment = &HFFFFEFF4
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
    End With
    '自动调整栏宽
    Set mSelection = mSheet.Range("A" & CStr(nRow) & ":" & GetExcelCols(nCol) & CStr(nTolRows))
    With mSelection
        .Columns.AutoFit
        .Rows.AutoFit
    End With
    oExcel.Visible = True
    '释放生成的Excel组件
    Set oExcel = Nothing
End SubPublic Function GetExcelCols(ByVal sCols As Integer) As String
    Dim sNum1 As Integer
    Dim sNum2 As Integer
    
    If sCols > 26 Then
        sNum1 = sCols \ 26
        sNum2 = sCols Mod 26
        If sNum2 = 0 Then '当为26的整数时
            GetExcelCols = Chr(64 + sNum1 - 1) & Chr(64 + 26)
        Else
            GetExcelCols = Chr(64 + sNum1) & Chr(64 + sNum2)
        End If
    Else
        GetExcelCols = Chr(64 + sCols)
    End If
End Function专用导到数据到Excel中，自己看了。因为直接以记录集导出。所以不管Access数据还是SQL Server数据库都一样。

Answer 5

其實想想，
可以設置成導出access某幾個字段，
就ok了嗎？

Answer 6

主要是这两个记录集，其它是可选参数，可以不用管它
rsDataRecordset:数据记录集
rsTitleRecordset:标题记录集
这个分成两个记录集，
第一个记录集，是标题记录集。
单一标题，那就一条记录,如: 工号   姓名   进厂日期第二个记录集，是数据记录集。是你要导出Excel的数据记录集唯一要求:你标题记录集每列标题与你数据每列对应。

Answer 7

仔細想想，
還是不能把access導出execl，
只能把DataGrid1顯示數據導出execl；
需修改以下代碼：conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\information.mdb;"
conn.CursorLocation = adUseClient
Set rs = conn.Execute("Info", , adCmdTable)“DataGrid1”數據是從Access篩選出來的；