将每列转移到一个工作表

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

ColumnA：

1. 第一行：House1
2. 第二行：山姆
3. Row3：皮平
4. 第四行：路加

ColumnB：

1. 第一行：House2
2. 第二行：亚当
3. Row3：Albert
4. 第四行：阿不思

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

我find了一些类似的代码 – 不是传输列，而是将一组数据传输到新的工作表中。 这是原来的代码，它工作正常：

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反转所有COLvariables，反之亦然，甚至交换参数。 但代码不运行，这是我改变它之后：

 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 

运行它似乎没有任何影响。 任何帮助这个解决scheme或代码？ 提前致谢！

Answer 1

这将工作在dynamic数量的列，基于表中的内容：

 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 2

这里有一段代码会将列拆分成工作表，假定列的第一行有一个值。

 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 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