Extracting & copying both cell data and file name from one workbook to another with VBA

[k10riley]

Hello!

I have create some code that consolidates a series of individual sheets into one sheet in another workbook. Currently the code copies three columns and adds this data to the sheet. My question is, how can I instead copy two columns and add the file name into the third column of the consolidated sheet. Code listed below, skip down the red comment.

Sub CopyRangeind()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
'location of workbooks you wish to consolidate information from
Const strPath As String = "C:\2020 Survey\"
ChDir strPath

'location of where the copied data will be pasted
wkbDest.Sheets("2020 Individual Responses").Range("B12:D" & rows.count - 1000).ClearContents
strExtension = Dir("*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource
'change .sheets("insert sheet name of sheet to be copied per workbook").cells.find
LastRow = .Sheets("Model Identification").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'remove duplicates, ignore blank sheets, and keeps header
'if statement determines the last row of your header -> LastRow > insert row number for bottom of header

****** Specifically here, currently this code is copying the columnsL C, D, and G. Instead of G I would like to copy the file name instead and place this into the new consolidated sheet (column D).************

If LastRow > 11 Then
.Sheets("Model Identification").Range("C9:D" & LastRow & ",G12:G" & LastRow).Copy wkbDest.Sheets("2020 Individual Responses").Cells(rows.count, "B").End(xlUp).Offset(1, 0)
End If
'closes workbooks that data is copied from
.Close savechanges:=False
End With


'sortcolumnB Macro, change the .worksheets("insert sheet you are sorting")
'adjust the Key:=Range("insert cell you are sorting on") and Order:=insert ascending, descending, etc.
ActiveWorkbook.Worksheets("2020 Individual Responses").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("2020 Individual Responses").Sort.SortFields.Add _
Key:=Range("B11"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("2020 Individual Responses").Sort
.SetRange Range("B12:D405")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub


Thanks!

 

[NdNoviceHlp]

Change that line to...

With wkbDest.Sheets("2020 Individual Responses")
Firstrow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
End With

Not real sure of the math. Please keep back up copy of your wb before using the code. Dave