其他分享
首页 > 其他分享> > VBA 格式化excel数据表 (数据分列)

VBA 格式化excel数据表 (数据分列)

作者:互联网

Sub ImportData()
'
' Copy  Data from one workbook to the Current Workbook
' Place the macro file in the same folder as the source file
'
    
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xlsx")
    Application.ScreenUpdating = False
    thrn = ThisWorkbook.Sheets(1).Range("A100000").Row
    With ThisWorkbook.Sheets(1)
        .Range("A1:T" & thrn).ClearContents
    End With
    Do While f <> ""
        
            If f <> ThisWorkbook.Name Then
                Set wb = GetObject(p & f)
                With wb.Sheets(1)
                  rn = .Range("A100000").End(xlUp).Row
                  ThisWorkbook.Sheets(1).Range("A1:T" & rn).Value = .Range("A1:T" & rn).Value
                  MsgBox "Format Complete."
                End With
            End If
            
        f = Dir
    Loop
    
End Sub

Sub Text_to_Columns()
'Formatted Data Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _ 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _ , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 3), Array(17, 1), Array(18, 1), _ Array(19, 1), Array(20, 1)), DecimalSeparator:=".", ThousandsSeparator:=",", _ TrailingMinusNumbers:=True Columns("A:T").Select Selection.Copy End Sub Sub Copy_Back() ' ' Copy back the formatted data to the source file ' p = ThisWorkbook.Path & "\" f = Dir(p & "*.xlsx") Application.ScreenUpdating = False thrn = ThisWorkbook.Sheets(1).Range("A100000").Row Do While f <> "" If f <> ThisWorkbook.Name Then Set wb = GetObject(p & f) With wb.Sheets(1) rn = .Range("A100000").End(xlUp).Row .Range("A1:T" & rn).ClearContents .Range("A1:T" & thrn).Value = ThisWorkbook.Sheets(1).Range("A1:T" & thrn).Value MsgBox "Complete." End With End If f = Dir Loop ThisWorkbook.Sheets(1).Range("A1:T" & thrn).ClearContents wb.Save 'Make sure the source file is already open End Sub Sub ExecConvert() ' 'Execute Macros ' Call ImportData Call Text_to_Columns Call Copy_Back End Sub

  

标签:ThisWorkbook,VBA,End,Sub,excel,数据表,Range,Sheets,Array
来源: https://www.cnblogs.com/luoye00/p/11358409.html