将列移动到新工作表excel VBA答案

【问题标题】：moving columns to new sheet excel VBA将列移动到新工作表excel VBA
【发布时间】：2021-03-16 06:57:55
【问题描述】：

所以我有一张包含信息的表格（大约 200 列），我想将其移至新表格。这个想法是我需要在每个新工作表中的 A 列，然后是 B 列，然后下一张表再次列 A + C 列，依此类推，直到最后一列。有人可以帮我解决这个问题吗？

Sub copyColumns()
    
    Columns("A:B").Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    
    Sheets("Sheet1").Select
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet4").Select
    Columns("C:C").Select
    ActiveSheet.Paste
    
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Range("A:B,D:D").Select
    Range("D1").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet5").Select
    ActiveSheet.Paste

End Sub

【问题讨论】：

Columns("A:B").Select Selection.Copy Sheets.Add After:=ActiveSheet ActiveSheet.Paste Sheets("Sheet1").Select Columns("C:C").Select Application .CutCopyMode = False Selection.Copy Sheets("Sheet4").Select Columns("C:C").Select ActiveSheet.Paste Sheets.Add After:=ActiveSheet Sheets("Sheet1").Select Range("A:B, D:D").Select Range("D1").Activate Application.CutCopyMode = False Selection.Copy Sheets("Sheet5").Select ActiveSheet.Paste End Sub
这是迄今为止我使用宏编写的代码。问题是如何让它自动执行到最后一列？
所以您需要大约 200 张新床单？
请不要像这样在 cmets 中添加代码。编辑您的原始问题，使您的帖子易于阅读，以便从社区获得一些帮助。
请注意，工作簿中的最大工作表数为 255。无论如何，您应该重新考虑在工作簿中拥有这么多工作表是否可行。请edit您的问题并包括所有这些的目的。我认为你的方法已经走错了。

标签： excel vba

【解决方案1】：

复制列

下面将复制列 A,B,C 然后 A,B,D 然后 A,B,E... 等每个到一个新的工作表。

Option Explicit

Sub copyColumns()
    
    Const sName As String = "Sheet1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    ' Define Last column.
    Dim sLast As Long
    sLast = sws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    
    Application.ScreenUpdating = False
    
    ' Add worksheets.
    Dim n As Long
    For n = 3 To sLast
        With wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            Union(sws.Columns("A:B"), sws.Columns(n)).Copy .Columns("A")
        End With
    Next n
    
    ' Delete columns.
    'sws.Columns(3).Resize(, sLast - 2).Delete (- 3 + 1 = - 2)
    
    Application.ScreenUpdating = False

End Sub

当添加（处理）如此多的工作表时，如果出现问题，您可能希望能够轻松删除它们：

Sub deleteWorksheetsExcept()
    Const ProcName As String = "deleteWorksheetsExcept"
    On Error GoTo clearError
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim arr As Variant: ReDim arr(1 To wb.Worksheets.Count)
    Dim ws As Worksheet
    Dim n  As Long
    For Each ws In wb.Worksheets
        Select Case ws.Name ' add/remove exact names from the following list:
        Case "Sheet1", "Sheet2", "Sheet3" ' worksheets to keep
        Case Else
            n = n + 1
            arr(n) = ws.Name
        End Select
    Next ws
    If n > 0 Then
        ReDim Preserve arr(1 To n)
        Application.DisplayAlerts = False
        wb.Worksheets(arr).Delete
        Application.DisplayAlerts = True
    End If

ProcExit:
    Exit Sub
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Sub

【讨论】：

【解决方案2】：

Sub ColumnsCopy()

 Dim rngSrc as Range
 Set rngSrc=ThisWorkbook.Sheets("main_sheet_name").UsedRange
 intMaxRows=rngSrc.Rows.Count
 intSheetsCnt=rngSrc.Columns.Count

 For shtNum = 3 To intSheetsCnt-1

 With Worksheets.Add(After:=Sheets(Sheets.Count))

  rngSrc.Copy Destination:=[A1]
  ActiveSheet.Range(Cells(1, 3), Cells(intMaxRows, shtNum)).EntireColumn.Delete

 End With
 Next shtNum
End Sub

【讨论】：