VBA Excel Copy Column to other worksheet with offset - vba

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