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

你可以循环遍历范围，就好像它是一个数组：

{{1}}

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

Answer 2

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 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

VBA Excel复制列到偏移量为

3 个答案: