Question

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

ColumnA：

第1行：House1
Row2：Sam
第3行：皮平
Row4：Luke

ColumnB：

第1行：House2
Row2：Adam
Row3：Albert
Row4：Albus

然后在运行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

这是一段将列拆分为工作表的代码，假设列在第一行中有值。

Option Explicit

Sub Main()
    '---Variables---
    Dim source As Worksheet
    Dim column As Long
    Dim i As Long

    '---Customize---
    Set source = ThisWorkbook.Sheets(1) 'The source sheet containing the data

    '---Logic---
    i = 1
    'Get the last column with a value in row 1
    column = source.Cells(1, source.Columns.Count).End(xlToLeft).column
    Do While i <= column
        If source.Cells(1, i).Value <> "" Then
            'Add the sheet
            ThisWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = _
                "Column" & i
            'Copy the entire column to the new sheet
            ThisWorkbook.Sheets("Column" & i).Range("A1").EntireColumn.Value = _
                source.Cells(1, i).EntireColumn.Value
        End If
        i = i + 1
    Loop
End Sub

Answer 2

根据表格中的内容，这将适用于动态数量的列：

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

Answer 3

尝试一下：

Sub Kolumn()
    Dim s1 As Worksheet
    Set s1 = ActiveSheet
    Sheets.Add
    ActiveSheet.Name = "ColumnA"
    s1.Range("A:A").Copy Range("A1")
    Sheets.Add
    ActiveSheet.Name = "ColumnB"
    s1.Range("B:B").Copy Range("A1")
End Sub

将每列传输到一个工作表

3 个答案: