Copy selected columns from source excel in a active workbook and copy them into specific column

I'm trying to use an active workbook to select some specific columns from a source workbook and copy them to the specific location in a new excel workbook

Here is my source workbook
I want to copy columns F and G into a new workbook

Here is my active workbook example
If I type 'Hello' in type, 'Hi' in Code, and '20230302' in Date, it should have the same amount of rows as the copied data. And cell B7 is my source excel path

The Header order of the output excel should exactly be the same as the active book. Type Code Date Title Person

My code:

Sub copy_column()
    Dim wbActive As Workbook, wbSource As Workbook, wbNew As Workbook
    Dim wsActive As Worksheet, wsSource As Worksheet, wsNew As Worksheet
    Dim rngCopy As Range
    Dim lastRow As Long, nlstclm As Long
    Dim clm As Range
    
    Set wbActive = ThisWorkbook
    Set wsActive = wbActive.Sheets("Sheet1") 'rename to suit
    
    If WorksheetFunction.CountA(wsActive.Range("B2:B6")) = 0 Then
        MsgBox "No column to copy."
        Exit Sub
    End If
    
    Set wbSource = Workbooks.Open(wsActive.Range("B7")) 'rename to suit
    Set wsSource = wbSource.Sheets("Sheet1") 'rename to suit

    Set wbNew = Workbooks.Add
    Set wsNew = wbNew.Sheets("Sheet1")
   
    For Each clm In wsActive.Range("B2:B6")
        If clm <> Empty Then
            lastRow = wsSource.Cells(Rows.Count, CStr(clm)).End(xlUp).Row
            Set rngCopy = wsSource.Range(CStr(clm) & "2:" & CStr(clm) & lastRow)
            If wsNew.Cells(1, 1) = Empty Then
                nlstclm = wsNew.Cells(1, Columns.Count).End(xlToLeft).Column
            Else
                nlstclm = wsNew.Cells(1, Columns.Count).End(xlToLeft).Column + 1
            End If
            wsNew.Cells(1, nlstclm) = clm.Offset(0, -1)
            rngCopy.Copy wsNew.Cells(2, nlstclm)
        End If
    Next
    
    wbNew.SaveAs wsActive.Cells(7, 2) & "Output.xlsx" 'rename to suit
    wbNew.Close False
    wbSource.Close False
    
    Set wbActive = Nothing
    Set wbSource = Nothing
    Set wbNew = Nothing
    
    MsgBox "Copy completed."
End Sub

I can copy my column to cell A1 but not in the specific location. Also, how to add the specific tag that has the same amount of rows as the copied column?

And here is a link to my expected outputs

Solution

If I understand you correctly, the sub below is not complete but maybe can help you to get started.

Sub test()
'Set shSrc = Workbooks("source.xlsm").Sheets(1)

Set wbActive = ThisWorkbook
Set wsActive = wbActive.Sheets("Sheet1") 'rename to suit

Set wbSource = Workbooks.Open(wsActive.Range("B7")) 'rename to suit
Set wsSource = wbSource.Sheets("Sheet1") 'rename to suit

'With ActiveSheet
With wsActive
   Set c = .Range("B2")
   cnt = Application.CountA(wsSource.Columns(Cells(1, .Range("B5").Value).Column)) - 1
End With

Set wbNew = Workbooks.Add

With wbNew.Sheets(1)
    .Range("A1").Resize(1, 6).Value = Array("Type", "Code", "Date", "Title", "Person", "Number")
    LR = .Range("A" & Rows.Count).End(xlUp).Row + 1
    For i = 1 To 6
        Set rg = c
        If i = 6 Then
            .Cells(LR, i).Resize(cnt, 1).Value = 1
        Else
            If i = 4 Or i = 5 Then _
            Set rg = wsSource.Cells(2, c.Value): Set rg = Range(rg, rg.End(xlDown)):wbSource.activate:wsSource.activate:rg.select:wbNew.activate
            .Cells(LR, i).Resize(cnt, 1).Value = rg.Value
            Set c = c.Offset(1, 0)
        End If
    Next i
End With

End Sub

The c variable it to get the cell value in the active sheet to be copied to the new workbook.

cnt is to count how many item in the source sheet which column is coming from activesheet cell B5 value. So the code assumed that the active sheet cell B5 is fixed will always be a column letter refferencing to the source sheet. The code also assumed that the source sheet which column is coming from activesheet cell B6 value has the same count.

After it create a new workbook as wbNew, within wbNew sheets(1) :

create a 6 columns header starting from cell A1.
get the row number of the last row of data in column A.
Loop for six times as i variable where within the loop :
it set rg variable from c
it check if i = 6 then it fill the last column with 1
if i = 4 or 5, it get the rg from shSrc
then it fill each column with rg value

For the rest of the code to save the newWb I'm sure you can do it.

I add a "checking" code line which later it can be removed :
original code :
Set rg = wsSource.Cells(2, c.Value): Set rg = Range(rg, rg.End(xlDown))

after adding "checking" code :
Set rg = wsSource.Cells(2, c.Value): Set rg = Range(rg, rg.End(xlDown)): wbSource.activate:wsSource.activate:rg.select:wbNew.activate ---> Does it give a correct result for rg selection?

And before .Cells(LR, i).Resize(cnt, 1).Value = rg.Value ... try to add .Cells(LR, i).Resize(cnt, 1).select. In the first iteration, does it select a blank cells in column A with rows as many as the cnt ?