Question

我对宏很天真。我使用下面的代码根据同一工作簿中从sheet1到sheet2的列标题复制数据。但是，当一个单元格为空时，它会停止复制。列中的某些单元格为空。所以，我需要宏来复制整个列数据，包括空单元格。

另外，我需要在两个不同的工作簿之间复制相同类型的宏。如果有人能为此提供宏，我感激不尽。

Sub CopyHeaders()
    Dim header As Range, headers As Range
    Set headers = Worksheets("ws1").Range("A1:Z1")

    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
            Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
        End If
    Next
End Sub

Function GetHeaderColumn(header As String) As Integer
    Dim headers As Range
    Set headers = Worksheets("ws2").Range("A1:Z1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

由于

Answer 1

更新：将列复制到具有匹配列标题的其他工作簿。

Sub CopyHeaders()

    Dim ws2 As Worksheet
    Dim header As Range, headers As Range
    Set headers = Worksheets("ws1").Range("A1:Z1")
    Dim headerColumn As Long

    Set ws2 = Workbooks("Some Other Workbook").Worksheets("ws2")

    For Each header In headers
        headerColumn = GetHeaderColumn(ws2, header.Value)
        If headerColumn > 0 Then
            header.Offset(1, 0).EntireColumn.Copy Destination:=ws2.Cells(1, headerColumn)
        End If
    Next
End Sub

Function GetHeaderColumn(ws2 As Worksheet, header As String) As Integer
    Dim headers As Range
    Set headers = ws2.Range("A1:Z1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

根据包含空单元格的列标题将数据从一个工作表复制到另一个工作表

1 个答案: