Copy columns between worksheets but only until last row

[ihb95]

Hello everyone!
For a small project I am having the following issue at the moment:

I copy columns from one worksheet into the other, depending on what is written in the first row.
Let's say if it says "Name" then it will copy the entire column to the other worksheet.
Now I have the problem that it copies the entire column. By that I mean that also all empty cells are copied as well, which I would like to change.
How can I make the code so that it only copies data from until the last row that has actual data in it?

So the code is very simple and looks like following:

Public Sub copy()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    

 
    Set Source = ActiveWorkbook.Worksheets("Data")
    Set Target = ActiveWorkbook.Worksheets("dont_touch")

    j = 1     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("A1:Z1")   ' Do 1000 rows
        If c = "Name" Then
           Source.Columns(c.Column).Copy Target.Columns(j)
           j = j + 1
        End If
    Next c
    j = 2     ' Start copying to row 2 in target sheet
    For Each c In Source.Range("A1:Z1")   
        If c = "Age" Then
           Source.Columns(c.Column).Copy Target.Columns(j)
           j = j + 1
        End If
    Next c
   Application.ScreenUpdating = True
    
End Sub

Thanks a lot in advance!

[Marc L]

Hi !

Use the UsedRange property of the source worksheet …

[alansidman]

Untested as you did not provide a worksheet.

Option Explicit

Public Sub copy()
    Dim c As Range
    Dim j As Integer, i As Long
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim lr As Long

 
    Set Source = ActiveWorkbook.Worksheets("Data")
    Set Target = ActiveWorkbook.Worksheets("dont_touch")

    j = 1     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("A1:Z1")   ' Do 1000 rows
        If c = "Name" Then
        i = Columns(c.Column)
        lr = Source.Cells(Rows.Count, i).End(xlUp).Row
        Source.Range(Cells(1, i), Cells(lr, i)).copy Target.Columns(j)
           j = j + 1
        End If
    Next c
    j = 2     ' Start copying to row 2 in target sheet
    For Each c In Source.Range("A1:Z1")
        If c = "Age" Then
        i = Columns(c.Column)
        lr = Source.Cells(Rows.Count, i).End(xlUp).Row
        Source.Range(Cells(1, i), Cells(lr, i)).copy Target.Columns(j)
           j = j + 1
        End If
    Next c
   Application.ScreenUpdating = True
    
End Sub

[jolivanes]

Sub Maybe()
Dim c As Range, headerArr, i As Long
headerArr = Array("Name", "Age")    '<----- extend as far as you need
For i = LBound(headerArr) To UBound(headerArr)
    For Each c In Range(Cells(1, 1), Cells(1, Cells(Columns.Count).End(xlToLeft).Column))
        If c.Value = headerArr(i) Then Range(Cells(1, c.Column), Cells(c.End(xlDown).Row, c.Column)).Copy Sheets("Sheet2").Cells(1, Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column + 1): Exit For
    Next c
Next i
End Sub

Change references where required


Slight difference.

Sub Maybe_A()
Dim headerArr, sh1 As Worksheet, sh2 As Worksheet, cCol As Long, i As Long, nc As Long
headerArr = Array("Name", "Age", "Address")    '<---- extend as far as required
Set sh1 = Worksheets("Data")
Set sh2 = Worksheets("dont_touch")
    For i = LBound(headerArr) To UBound(headerArr)
        With sh1
            cCol = .Rows(1).Find(headerArr(i)).Column
            nc = IIf(WorksheetFunction.CountA(sh2.Rows(1)) = 0, 1, sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 1)
            .Range(.Cells(1, cCol), .Cells(.Cells(.Rows.Count, cCol).End(xlUp).Row, cCol)).Copy sh2.Cells(1, nc)
        End With
    Next i
End Sub

[ihb95]

Hey guys,
sorry for the late reply. I was out of office for a week.

I tried all your options and I am very thankful for your replies (!!!), but none of them really do the thing.

I attached the file.
When you add a new name in "Data", the copy-function is called and in "dont_touch" it will appear. But you can see then, that the whole column until the infinites cell was copied.
Therefore, when you then try to open the "Sternenhimmel" worksheet, Excel will crash.
How can I make the copy function copy only until the last used row?

Best regards!