VBA Excel将列复制到具有偏移量的其他工作表

Question

我发现这段代码可以满足我 99% 的需求。

过程描述：在我的工作簿中，有一个带有命名列的 SQL 工作表，基于列标题我必须遍历工作簿中列标题具有相同名称的所有其他工作表（从 10 到 50 个工作表） ，源 SQL 表中的所有列都将复制到目标表中。在目标表中，列标题由 4 行组成，在源中，列标题只有 1 行。

• 问题 1：如何复制没有标题的列并粘贴偏移量为 4 行的内容。

• 问题 2：如何仅复制实际使用的范围，工作簿越来越大。

代码示例：

    Sub Test()
Dim Sh2Cell As Range
Dim Sh3Cell As Range
Dim ShQuelleTitle As Range
Dim ShZielTitle As Range

'Here we loop through the Range where the Title Columns for source and goal sheet are stored
'The columns in the Source Sheet do not have the same order as in the Goal Sheet


Set ShQuelleTitle = Sheets("SQL").Range("SQL_Titel")
Set ShZielTitle = Sheets("Ziel").Range("Ziel_Titel")

For Each Sh2Cell In ShQuelleTitle
    For Each Sh3Cell In ShZielTitle
        If Sh2Cell = Sh3Cell Then
            Sh2Cell.EntireColumn.Copy Sh3Cell.EntireColumn

            ' Problem-1 is: in the goal sheet the copy range has to be shifted 4 rows down because
            ' i have different column title structure which has to be maintained (with this goal
            ' sheet there happens a txt-export from another external developer.

            ' Problem-2 is: how can i only copy and paste cells with content - the worksheets are getting
            ' huge on file size if the copy range has some weird formatting

        End If
    Next
Next
End Sub

Answer 1

Sub UpDateData()
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim wData As Worksheet
Dim Process(1 To 2) As String
Dim iProc As Long
Dim Dict As Object

    Process(1) = "SQL"
    Process(2) = "ACCOUNT ACC STD"
    Set wData = Sheets("ACCOUNT")
    Set Dict = CreateObject("Scripting.Dictionary")

    With wData
        For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            If Len(.Cells(1, j)) > 0 Then Dict.Add LCase$(.Cells(1, j)), j
        Next j
    End With

    i = 5

    For iProc = 1 To 2
        With Sheets(Process(iProc))
            n = .Cells(.Rows.Count, 1).End(xlUp).Row

            For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                If Dict.exists(LCase$(.Cells(1, j))) Then
                    k = Dict(LCase$(.Cells(1, j)))
                    .Cells(2, j).Resize(n - 1).Copy wData.Cells(i, k).Resize(n - 1)
                End If
            Next j

        End With
        i = i + n - 1

    Next iProc
End Sub

Answer 2

你可以像数组一样循环遍历范围：

Dim srcRng As Range
dim trgRng  As Range
Dim iii As Long
Dim jjj As Long
Dim iRowStart As Long

Set srcRng = Sheets("your_source_sheet").Range("source_range")
Set trgRng = Sheets("your_target_sheet").Range("target_range")
iRowStart = 4

For iii = iRowStart To UBound(srcRng(), 1)
    For jjj = 1 To UBound(srcRng(), 2) ' <~~ necessary only if you were dealing with more than one column 
        With trgRng
            If srcRng(iii, jjj).Value <> "" Then .Cells(.Rows.Count + 1, jjj).Value = srcRng(iii, jjj).Value
        End With
    Next jjj
Next iii

Set srcRng = Nothing
Set trgRng = Nothing

我还没有测试过代码，但它应该可以解决问题

Answer 3

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(4, 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