VBA Excel Copy Column to other worksheet with offset

Question

I found this piece of code which does 99% what i need.

Procedure description: In my workbook there is one SQL Sheet with named columns, based on the Column Header I have to loop through all other sheets (variable from 10 to 50 sheets) in the workbook where the Column Header has the identical name, all columns from the source SQL Sheet are copied to the goal sheets. In the goal sheets the column header consist of 4 rows, in the source the column header has only 1 row.

• Problem-1: How can I copy the column without the header and paste the content with an offset of 4 rows.

• Problem-2: How can I copy only the real used range, the workbook is getting huge.

Code-Sample:

    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

You can loop through range as if it was an array:

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

I haven't tested the code, but it should do the trick

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