excel宏的代码，该宏根据列标题和工作表名称之间的匹配将数据列复制到另一个工作表中？

编程问答 2022-08-15

问题描述

我刚刚发现Excel中存在宏，我非常高兴，因为它们提供了许多有趣的可能性。 目前，我有一个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

解决方法

类似的事情应该起作用：

Sub sbCopyRangeToAnotherSheet()

    Dim col as range
    For each col in activesheet.range("A1").Resize(15,36).Columns
        col.copy activeworkbook.worksheets(col.cells(1).Value).Range("G5") 'for example
    Next col

End Sub
,

您需要做的就是遍历`Sheets（“ ROW X”）中标题行中的每个单元格，复制列范围，然后使用单元格的值作为名称将范围粘贴到正确的工作表中。工作表。

With ThisWorkbook.Sheets("ROW X")
    For Each cel In .Range("A1:AJ1")
        .Range(.Cells(1,cel.Column),.Cells(.Rows.Count,cel.Column).End(xlUp)).Copy Sheets(cel.Value).Range("A1")
    Next cel
End With
,

复制列范围

  • 主子为copyColumn，即第三子。背后的潜艇正在 被它调用。
  • 第一个Sub是一个示例，说明如何将主Sub用于一个工作表， 而第二个是更严重的例子 名称未包含在Exceptions数组中的工作表。
  • 这会将源工作表（ROW_X）中“适当”列范围内的值从标题下方的一个单元格复制到包含数据的最后一个单元格，并将其粘贴到“适当”目标工作表中（ POT_1,POT_2 ...）从指定的单元格地址（TargetFirstCell）开始。

代码 

Option Explicit

Sub runCopyColumn()

    Call 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
            Call 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
    Call defineHeaderCellRange(rng,src,tgt.Name)
    If rng Is Nothing Then Exit Sub
    
    Dim Data As Variant
    Call getColumnRange(Data,rng,IncludeHeaders)
    If IsEmpty(Data) Then Exit Sub
    
    Call 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,"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) = rng.Value
        End If
    End If
    
    Exit Sub

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

End Sub

Sub defineTargetFirstCell(ByRef rng As Range,_
                          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,"Error in '" & proc & "'"

End Sub
copy-pasteexcelexcel