PDA

View Full Version : [SOLVED] Extract & paste the filename into another workbook



bananas
08-18-2016, 09:42 AM
Hi,
I want to do this:

1 Open every workbook in the folder C:\Station\Div\ABC\Test\Test3\.

2 Do some c&p (see code) before copy R19 (in all workbooks in Test3 folder) to "C:\Station\Div\ABC\Test\vikt.xlsm", sheet1, column W.

So far everything in code works fine but then I want to:

3 Put the filename of every wb into the corresponding row in column X.

I have tested alot but can't get anything to work. (I'm new to VBA)



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


Any help is much appreciated, Thanks

bananas
08-20-2016, 02:14 AM
Problem solved.
All credit to "dchaney" at MrExcel


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