How to extract & paste the filename into another workbook?

soidog

New Member
Joined
May 26, 2016
Messages
45
Hello,
I'm having a problem with extracting and paste the filename into another workbook.

I have code for:
Copy Cell "R19" in "Sheet1", in every workbook in folder "Test3".
Paste that value into workbook: "vikt.xlsm", column "W" with:
Workbooks("vikt.xlsm").Worksheets("Sheet1").Range("W" & Rows.count).End(xlUp).Offset(1). _
PasteSpecial Paste:=xlPasteValues.

But how to:
Adjacent to that value in column "W", insert in column "X", the workbook name the value came from?

Any help would be much appreciated. :)
Thanks.
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Can you post your entire code? Will make it easier to help...

Please use the code tags...
 
Upvote 0
Ok, here comes the code:


Sub CopyAllWBinFolder()


Dim wbk As Workbook
Dim wbdest As Workbook
Dim FileName As String
Dim Path As String


Path = "C:\Station\Div\ABC\Test\Test3\"
FileName = Dir(Path & "*.xlsm")
Set wbdest = Workbooks.Open("C:\Station\Div\ABC\Test\vikt.xlsm")


Do While Len(FileName) > 0
Application.ScreenUpdating = False
Set wbk = Workbooks.Open(Path & FileName, UpdateLinks:=0)

' Code
Workbooks("vikt.xlsm").Worksheets("Sheet1").Range("A2:R2").Copy
Range("B39:S39").PasteSpecial Paste:=xlPasteValues


Range("R19").Copy


Workbooks("vikt.xlsm").Worksheets("Sheet1").Range("W" & Rows.count).End(xlUp).Offset(1). _
PasteSpecial Paste:=xlPasteValues

'Here I need to paste Workbook name in column X


wbk.Close SaveChanges:=False
FileName = Dir
Loop
Application.ScreenUpdating = True


End Sub
 
Upvote 0
Sorry,

Code:
Sub CopyAllWBinFolder() 
     
     
    Dim wbk As Workbook 
    Dim wbdest As Workbook 
    Dim FileName As String 
    Dim Path As String 
     
     
    Path = "C:\Station\Div\ABC\Test\Test3\" 
    FileName = Dir(Path & "*.xlsm") 
    Set wbdest = Workbooks.Open("C:\Station\Div\ABC\Test\vikt.xlsm") 
     
     
    Do While Len(FileName) > 0 
        Application.ScreenUpdating = False 
        Set wbk = Workbooks.Open(Path & FileName, UpdateLinks:=0) 
         
         [COLOR=darkgreen]' Code[/COLOR]
        Workbooks("vikt.xlsm").Worksheets("Sheet1").Range("A2:R2").Copy 
        Range("B39:S39").PasteSpecial Paste:=xlPasteValues 
         
         
        Range("R19").Copy 
         
         
        Workbooks("vikt.xlsm").Worksheets("Sheet1").Range("W" & Rows.count).End(xlUp).Offset(1). _ 
        PasteSpecial Paste:=xlPasteValues 
         
         [COLOR=darkgreen]'Here I need to paste Workbook name in column X[/COLOR]
         
         
        wbk.Close SaveChanges:=False 
        FileName = Dir 
    Loop 
    Application.ScreenUpdating = True 
     
     
End Sub
 
Upvote 0
Here try this, also removed all the copys (clears the clipboard makes it smoother)

Code:
Sub CopyAllWBinFolder()       
Dim FileName As String, Path As String
Dim wbk As Workbook, wbdest As Workbook

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Path = "C:\Station\Div\ABC\Test\Test3\"
FileName = Dir(Path & "*.xlsm")

Set wbdest = Workbooks.Open("C:\Station\Div\ABC\Test\vikt.xlsm")
 
Do While Len(FileName) > 0

    Set wbk = Workbooks.Open(Path & FileName, UpdateLinks:=0)
     
     ' Code
    wbk.Sheets(1).Range("B39:S39") = wbdest.Worksheets("Sheet1").Range("A2:R2").Value
        
    wbdest.Worksheets("Sheet1").Range("W" & Rows.Count).End(xlUp).Offset(1) = wbk.Sheets(1).Range("R19")
    wbdest.Worksheets("Sheet1").Range("X" & Rows.Count).End(xlUp).Offset(1) = wbk.Name
     
    wbk.Close SaveChanges:=False
    FileName = Dir
Loop
  
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub
 
Last edited:
Upvote 0
That is so BEAUTIFUL!!!
Two days on Google search to no avail and now you come up with this absolutely gorgeous solution in 5 minutes.
THANKS ALOT!!! :cool:
 
Upvote 0
That is so BEAUTIFUL!!!
Two days on Google search to no avail and now you come up with this absolutely gorgeous solution in 5 minutes.
THANKS ALOT!!! :cool:

Well an Another solution May be this, Check if it might help you

Code:
Sub LoopThroughFiles()
    
    FolderName = "D:\Work\Sample"
    If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
    Fname = Dir(FolderName & "*.xlsx")


    'loop through the files
    Do While Len(Fname)


        With Workbooks.Open(FolderName & Fname)


        
 
    Range("a1").Select
    Selection.Copy
    ActiveWindow.Close
    Windows("Exp.xlsm").Activate
    Dim LastBlankRow As Long
    Range("w1").Select
    LastBlankRow = Cells(Rows.Count, 23).End(xlUp).Row + 1
    Cells(LastBlankRow, 23).Select
    ActiveCell.PasteSpecial
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, 1).Select
        End With


        ' go to the next file in the folder
        Fname = Dir


    Loop
Call Get_File_Names
End Sub




Code:
Option Explicit
 
Sub Get_File_Names()
     
    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$
     
    InitialFoldr$ = "D:\Work\Sample" '<<< Startup folder to begin searching from
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr$
        .Show
        If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)
            Do While xFname$ <> ""
                ActiveCell.Offset(xRow) = xFname$
                xRow = xRow + 1
                xFname$ = Dir
            Loop
        End If
    End With
End Sub

Basically Just change the Folders And Put this Macro in your Main Macro File Where you want changes to be made.


A Simple Like would be appreciated.
 
Upvote 0
CPatel13,

I tried it and it works.
The part with the "FileDialog" was new to me. It will come in handy for my other project.
Thanks alot!!!:cool:
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,194
Members
448,554
Latest member
Gleisner2

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