excel - 如何根据列标题和工作表名称之间的匹配将数据列复制到另一个工作表中？

Question

我有一个 Excel 选项卡（“ROW X”），其中包含 36 列和 15 行的数据框。我有 36 个空选项卡，每个选项卡都标记为数据框的列之一（“POT_1”、“POT_2”等）。

我想从第一个工作表中复制一列（例如“POT_1”）并将其粘贴到名称与列标题匹配的工作表中的精确位置）。

我可以找到一些代码将工作表的某个部分手动粘贴到另一个工作表中（见下文），但使用这种方法，我必须手动输入 36 个工作表名称中的每一个。

Sub sbCopyRangeToAnotherSheet()

Sheets("ROW 4").Range("B2:C2").Copy

Sheets("SP6_ST_5").Activate

Range("C9:C10").Select

ActiveSheet.Paste

Application.CutCopyMode = False

End Sub

标签： excelvbacopy-paste

Answer 1

复制列范围

• 主副是copyColumn，第三副。后面的 Subs 正在被它召唤。
• 第一个 Sub 是如何将主 Sub 用于一个工作表的示例，而第二个是更严重的示例，用于名称不包含在Exceptions数组中的所有工作表。
• ROW_X这将从标题下方的一个单元格开始从源工作表 ( ) 中的“适当”列范围复制值到包含数据的最后一个单元格，并将其粘贴到POT_1, POT_2 ...从指定单元格地址开始的“适当”目标工作表 () TargetFirstCell）。

编码

Option Explicit

Sub runCopyColumn()

    copyColumn ThisWorkbook, "ROW_X", "POT_1", "A2", True

End Sub

Sub runCopyColumnAll()
    
    Const SourceID As Variant = "ROW_X"
    Const TargetFirstCell As String = "A2"
    Dim Exceptions As Variant: Exceptions = Array("ROW_X") ' add more ...
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim ws As Worksheet
    For Each ws In wb.Worksheets
        If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
            copyColumn ThisWorkbook, SourceID, ws.Name, TargetFirstCell
        End If
    Next ws

End Sub

Sub copyColumn(Book As Workbook, _
               SourceID As Variant, _
               TargetID As Variant, _
               TargetFirstCellAddress As String, _
               Optional IncludeHeaders As Boolean = False)
    
    Const proc As String = "copyColumn"
    On Error GoTo cleanError
    
    Dim src As Worksheet: Set src = Book.Worksheets(SourceID)
    Dim tgt As Worksheet: Set tgt = Book.Worksheets(TargetID)
    
    Dim rng As Range
    defineHeaderCellRange rng, src, tgt.Name
    If rng Is Nothing Then Exit Sub
    
    Dim Data As Variant
    getColumnRange Data, rng, IncludeHeaders
    If IsEmpty(Data) Then Exit Sub
    
    defineTargetFirstCell rng, tgt, TargetFirstCellAddress
    If rng Is Nothing Then Exit Sub
    
    ' Write result to Target Range.
    rng.Resize(UBound(Data)).Value = Data

    Exit Sub

cleanError:
    MsgBox "Run-time error '" & Err.Number & "': " & Err.Description, _
           vbCritical, "Error in '" & proc & "'"

End Sub

Sub defineHeaderCellRange(ByRef HeaderCellRange As Range, _
                          Sheet As Worksheet, _
                          Header As String)
    
    Const proc As String = "defineHeaderCellRange"
    On Error GoTo cleanError
    
    Set HeaderCellRange = Sheet.Cells.Find( _
      Header, Sheet.Cells(Sheet.Rows.Count, Sheet.Columns.Count), _
      xlValues, xlWhole, xlByRows)
    
    Exit Sub

cleanError:
    MsgBox "Run-time error '" & Err.Number & "': " & Err.Description, _
           vbCritical, "Error in '" & proc & "'"

End Sub

Sub getColumnRange(ByRef Data As Variant, _
                   HeaderCellRange As Range, _
                   Optional IncludeHeaders As Boolean = False)
    
    Const proc As String = "getColumnRange"
    On Error GoTo cleanError
    
    Dim rng As Range
    Set rng = HeaderCellRange.Worksheet.Columns(HeaderCellRange.Column) _
      .Find("*", , xlValues, , , xlPrevious)
    If IncludeHeaders Then
        If rng.Row > HeaderCellRange.Row Then
            Data = HeaderCellRange.Worksheet.Range( _
                   HeaderCellRange, rng).Value
        Else
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
        End If
    Else
        If rng.Row = HeaderCellRange.Row Then Exit Sub
        If rng.Row > HeaderCellRange.Row + 1 Then
            Data = HeaderCellRange.Worksheet.Range( _
              HeaderCellRange.Offset(1), rng)
        Else
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
        End If
    End If
    
    Exit Sub

cleanError:
    MsgBox "Run-time error '" & Err.Number & "': " & Err.Description, _
           vbCritical, "Error in '" & proc & "'"

End Sub

Sub defineTargetFirstCell(ByRef rng As Range, _
                          Sheet As Worksheet, _
                          FirstCellAddress As String)
    
    Const proc As String = "defineTargetFirstCell"
    On Error GoTo cleanError
    
    Set rng = Sheet.Range(FirstCellAddress)
    ' Maybe you want to get rid of the previous data:
    'rng.Resize(Sheet.Rows.Count - rng.Row + 1).ClearContents ' or Clear ?
    
    Exit Sub

cleanError:
    MsgBox "Run-time error '" & Err.Number & "': " & Err.Description, _
           vbCritical, "Error in '" & proc & "'"

End Sub