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]

Seems like this would work...

.Sheets("Model Identification").Range("C9:D" & LastRow).Copy _
 wkbDest.Sheets("2020 Individual Responses").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
wkbDest.Sheets("2020 Individual Responses").Cells(Rows.Count, "B").End(xlUp).Offset(1, 2) = wkbSource.Name

U will need to also adjust the "If lastrow < 11 then" part of the code as well. HTH. Dave
ps. please use code tags

 

[k10riley]

Seems like this would work...

.Sheets("Model Identification").Range("C9:D" & LastRow).Copy _
 wkbDest.Sheets("2020 Individual Responses").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
wkbDest.Sheets("2020 Individual Responses").Cells(Rows.Count, "B").End(xlUp).Offset(1, 2) = wkbSource.Name

U will need to also adjust the "If lastrow < 11 then" part of the code as well. HTH. Dave
ps. please use code tags

Thanks! I have a ignorant question.

Where is the appropriate place to insert this into my code? Within the "if" statement?

I created this and placed it within, but it only pulled one file name and placed it in the A column.

If LastRow > 11 Then
.Sheets("Model Identification").Range("C9:D" & LastRow).Copy wkbDest.Sheets("2020 Individual Responses").Cells(rows.count, "B").End(xlUp).Offset(1, 0)

'copy the file names from individual sheets and paste to the consolidated response
wkbDest.Sheets("2020 Individual Responses").Activate
fRow = wkbDest.Sheets("2020 Individual Responses").Range("D" & Cells(rows.count, "D").End(xlUp).Row).Offset(0, 0).Row
lrow = wkbDest.Sheets("2020 Individual Responses").Range("D" & Cells(rows.count, "D").End(xlUp).Row).Row
wkbDest.Sheets("2020 Individual Responses").Range("A" & fRow) = wkbSource.Name

End If

 

[k10riley]

Wait! I got it! Is it possible to have that file name duplicate for every cell associated with the pasted data?

 

[k10riley]

Updated code - This works, however for some reason it isn't copying all the files in the folder and I would like to have the file name for each line of copied data. Thoughts?

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 remember to add \ at the end of the file path
Const strPath As String = "C:\2020 Individual Responses\"
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
If LastRow > 11 Then

********************Updated Code*******************
'copy the file names from individual sheets and paste to the consolidated response
.Sheets("Model Identification").Range("C9:D" & LastRow).Copy _
wkbDest.Sheets("2020 Individual Responses").Cells(rows.count, "B").End(xlUp).Offset(1, 0)
wkbDest.Sheets("2020 Individual Responses").Cells(rows.count, "B").End(xlUp).Offset(0, 2) = wkbSource.Name

***************************************************
End If
'closes workbooks that data is copied from
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[k10riley]

Final Solution for those who would like to see:

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 remember to add \ at the end of the file path
    Const strPath As String = "C:\2020 Individual Responses\"
    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
                              'copy the file names from individual sheets and paste to the consolidated response
                    .Sheets("Model Identification").Range("C9:D" & LastRow).Copy wkbDest.Sheets("2020 Individual Responses").Cells(rows.count, "B").End(xlUp).Offset(1, 0)
                     wkbDest.Sheets("2020 Individual Responses").Cells(rows.count, "B").End(xlUp).Offset(0, 2) = wkbSource.Name
            'closes workbooks that data is copied from
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
   
End Sub

 

[NdNoviceHlp]

Thanks for posting your outcome. Dave

 

[k10riley]

Thanks for posting your outcome. Dave

Thank you for your help Dave! Sorry for the delay on the code tags. I am wondering, and I can post in a new thread if needed. How can I make the filenames post for each row of data?

For example, in the image. I would like the Respondents (which contains the file name) to populate each corresponding row of data. Currently, it the filename populates the last cell that corresponds to its addition.

 

[NdNoviceHlp]

U can trial this....

Dim FirstRow As Integer, Total As Integer, Cnt As Integer

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
'copy the file names from individual sheets and paste to the consolidated response
.Sheets("Model Identification").Range("C9:D" & lastrow).Copy wkbDest.Sheets("2020 Individual Responses").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)

FirstRow = wkbDest.Sheets("2020 Individual Responses").Cells(Rows.Count, "B").End(xlUp) + 1
Total = lastrow - 9
For Cnt = FirstRow To (FirstRow + Total)
wkbDest.Sheets("2020 Individual Responses").Cells(Cnt, "B") = wkbSource.Name
Next Cnt


'closes workbooks that data is copied from
.Close savechanges:=False
End With
strExtension = Dir
Loop

Dave

 

[k10riley]

Hmm, I get a error message: Run time error 13 - type mismatch and it highlights:

FirstRow = wkbDest.Sheets("2020 Individual Responses").Cells(Rows.Count, "B").End(xlUp) + 1