Question

所以我有一个包含列（大约 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

Answer 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

Answer 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

将列移动到新工作表 excel VBA

2 个答案:

复制列