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

k10riley

New Member
Joined
Dec 1, 2021
Messages
24
Office Version
  1. 365
Platform
  1. Windows
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!
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Seems like this would work...
Code:
.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
 
Upvote 0
Seems like this would work...
Code:
.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
 
Upvote 0
Wait! I got it! Is it possible to have that file name duplicate for every cell associated with the pasted data?
 
Upvote 0
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
 
Upvote 0
Final Solution for those who would like to see:

VBA Code:
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
 
Upvote 0
Solution
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.

1638827830016.png
 
Upvote 0
U can trial this....
Code:
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,524
Messages
6,114,117
Members
448,549
Latest member
brianhfield

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top