vba - 将每一列转移到一个工作表

Question

正如标题所说，我希望使用 VBA 代码将工作表中的每一列转移到各自的新工作表中。例如:

A栏:

第 1 行:House1

第2行:山姆

第 3 行:皮平

第 4 行:卢克

B栏:

第 1 行:House2

第 2 行:亚当

第 3 行:阿尔伯特

第 4 行:阿不思

然后在运行 VBA 之后，将添加两个名为 ColumnA 和 ColumnB 的新工作表及其各自的数据，方式相同。

我在某处找到了一个类似的代码 - 它不是传输列，而是将一组数据行传输到新的工作表。这是原始代码，它工作正常:

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    vcol = 1
    Set ws = Sheets("109 (2)")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:C1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"

    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i,     vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If

        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) &     "").Range("A1")
        Sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate
End Sub

然后我想我可以用 ROW 反转所有 COL 变量，反之亦然，甚至交换参数。但是代码没有运行，这是我修改后的代码:

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vrow, i As Integer
    Dim irow As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlecol As Integer

    vrow = 1
    Set ws = Sheets("109 (2)")
    lr = ws.Cells(vrow, ws.Columns.Count).End(xlToLeft).Column
    title = "A1:J1"
    titlecol = ws.Range(title).Cells(1).Column
    irow = ws.Rows.Count
    ws.Cells(irow, 1) = "Unique"

    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(vcol, i) <> "" And Application.WorksheetFunction.Match(ws.Cells(vrow, i), ws.Rows(irow), 0) = 0 Then
            ws.Cells(irow, ws.Columns.Count).End(xlToLeft).Offset(1) = ws.Cells(vrow, i)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Rows(irow).SpecialCells(xlCellTypeConstants))
    ws.Rows(irow).Clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vrow, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlecol & ":A" & lr).EntireColumn.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate
End Sub

运行它似乎根本没有任何效果。对此解决方案或代码有任何帮助吗？提前致谢!

Answer 1

这将根据工作表中的内容处理动态数量的列:

Sub a()

    Dim col As Object

    With Sheets("SheetName")
        For Each col In .UsedRange.Columns
            Sheets.Add
            ActiveSheet.Name = "Column" & col.Column
            col.Copy Destination:=ActiveSheet.Cells(1, 1)
        Next col
    End With

End Sub