Copy filename from several workbooks to cells in another workbook - vba

I have a folder with alot of workbooks where i need to copy the file names (and some other data) to a master workbook. I found a code to import the data but is can't seem to import the file name.
After the "' >>>>>> Adapt this part" I tried to write some code to copy and paste the filename but it doesn't seem to work.
I use the part outside the "' >>>>>> Adapt this part" to copy some other data so I only need some code to fit in insted of my not working code :)
Sub Import_to_Master()
Dim sFolder As String
Dim sFile As String
Dim wbD As Workbook, wbS As Workbook
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
sFolder = wbS.Path & "\"
sFile = Dir(sFolder)
Do While sFile <> ""
If sFile <> wbS.Name Then
Set wbD = Workbooks.Open(sFolder & sFile)
' >>>>>> Adapt this part
WName = ActiveWorkbook.Name
WName.Copy
Sheets("Combined").Range("N" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
' >>>>>>
wbD.Close savechanges:=True 'close without saving
End If
sFile = Dir 'next file
Loop
Application.ScreenUpdating = True
End Sub

Sub Import_to_Master()
Dim sFolder As String
Dim sFile As String
Dim wbD As Workbook, wbS As Workbook
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
sFolder = wbS.Path & "\"
sFile = Dir(sFolder)
Do While sFile <> ""
If sFile <> wbS.Name Then
Set wbD = Workbooks.Open(sFolder & sFile)
' >>>>>> Adapt this part
wbS.Sheets("Combined").Range("N" & wbS.Sheets("Combined").Rows.Count).End(xlUp).Offset(1, 0).Value = sFile
' >>>>>>
wbD.Close savechanges:=True 'close without saving
End If
sFile = Dir 'next file
Loop
Application.ScreenUpdating = True
End Sub

You can directly use the object wbD and its property .Name.
I have also added a reference to the Sheet("Combined") for a better readability :
Sub Import_to_Master()
Dim sFolder As String
Dim sFile As String
Dim wbD As Workbook, wbS As Workbook
Dim wSc As Worksheet
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
'''Define the sheet
Set wSc = wbS.Sheets("Combined")
sFolder = wbS.Path & "\"
sFile = Dir(sFolder)
Do While sFile <> ""
If sFile <> wbS.Name Then
Set wbD = Workbooks.Open(sFolder & sFile)
' >>>>>> Adapt this part
wSc.Range("N" & wSc.Rows.Count).End(xlUp).Offset(1, 0).value = wbD.Name
' >>>>>>
wbD.Close savechanges:=True 'close without saving
End If
sFile = Dir 'next file
Loop
Application.ScreenUpdating = True
End Sub

Related

Copying a range from a hidden sheet

i have a vba code to copy and paste a range of data from multiple excel files in a folder. The sheet that has the data is hidden though. i need to modify my code to copy the hidden sheets range.
Sub Import_to_Master()
Dim sFolder As String
Dim sFile As String
Dim wbD As Workbook, wbS As Workbook
Application.ScreenUpdating = False Set wbS = ThisWorkbook sFolder =
wbS.Path & "\"
sFile = Dir(sFolder) Do While sFile <> ""
If sFile <> wbS.Name Then Set wbD = Workbooks.Open(sFolder & sFile)
'open the file; add condition to
' >>>>>> Adapt this part wbD.Sheets("data").Range("A3:BD3").Copy
wbS.Activate Sheets("data scorecards").Range("A" &
Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False ' >>>>>> wbD.Close savechanges:=True
'close without saving End If
sFile = Dir 'next file Loop Application.ScreenUpdating = True
End Sub
This looks appropriate. I've used direct value transfer instead of copy, paste special, values.
Option Explicit
Sub Import_to_Master()
Dim sFolder As String, sFile As String
Dim wbS As Workbook
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
sFolder = wbS.Path & "\"
sFile = Dir(sFolder & "*.xl*")
Do While sFile <> ""
If sFile <> wbS.Name Then
'open the file; add condition to
With Workbooks.Open(sFolder & sFile)
' >>>>>> Adapt this part wbD
With .Worksheets("data").Range("A3:BD3")
wbS.Worksheets("data scorecards").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
End With
'close without saving
.Close savechanges:=False
End With
End If
sFile = Dir 'next file
Loop
Application.ScreenUpdating = True
End Sub

Import CSV file with partial name in vba

First, let me brief scenario. I want to Import specific CSV file from the user-provided location. I am able to Import it with Fix file name.
Now, I want to Import a CSV file which changing one file name each time.
E.g.
Newdata_Files_LMBN_124587
Newdata_Files_LMBN_458965
Newdata_Files_LMBN_134654
Newdata_Files_LMBN_894354, etc...
I have written code for it, but it doesn't work
Sub zzandand(Optional opt As String)
Application.ScreenUpdating = False
Dim compd1, compd2 As String
Dim ws As Worksheet
Dim rng As Range
Dim path As Variant
Dim tfr1, tfr2 As String
Set path = UserForm1.TextBox1
compd1 = path & "\" & Newdata_Files_ & "*" & ".csv"
If Dir(compd1, vbDirectory) = vbNullString Then
MsgBox ("The file Newdata_Files(csv) could not be found")
Unload UserForm1
End
Else
Workbooks.Open (compd1)
ActiveSheet.Activate
Sheets.Copy Before:=ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = "compd2"
tfr1 = ActiveSheet.Range("A1").Value
ActiveSheet.Range("A1").Value = UCase(tfr1)
Workbooks("compd1").Close
End If
Application.ScreenUpdating = True
End Sub
Untested:
Sub zzandand(Optional opt As String)
Dim compd1 As String
Dim ws As Worksheet, wb As Workbook
Dim path As Variant
path = Trim(UserForm1.TextBox1)
If Right(path, 1) <> "\" Then path = path & "\" '<<< ensure trailing "\"
compd1 = Dir(path & "Newdata_Files_*.csv") '<<< any matches?
If Len(compd1) = 0 Then '<<< no need for Dir here....
MsgBox "The file Newdata_Files(csv) could not be found"
Unload UserForm1
Else
Set wb = Workbooks.Open(path & compd1) '<<< use the full path!
wb.Sheets(1).Copy _
Before:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close False 'close without saving
Set ws = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ws.Name = "compd2"
ws.Range("A1").Value = UCase(ws.Range("A1").Value)
End If
End Sub

How to Import Specific Sheet to Another Workbook with VBA

I try to create a program that can collect every "UTP" sheet in one folder into one "Master UTP" workbook (located in the same folder)
So, first I need to read all file xls in folder.
Copy "UTP" sheet and paste it to "Master UTP".
Then do looping again.
This is the code that I make so far in "Master UTP":
Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim sourceWb As Workbook, targetWb As Workbook
Set sourceWb = ActiveWorkbook
sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)
Do While Len(sFileName) > 0
sFileName = sPathName & sFileName
If sFileName <> sourceWb Then
Set targetWb = Workbooks.Open(sName)
targetWb.Sheets("UTP").Copy After:=sourceWb.Sheets("Master UTP")
targetWb.Close
End If
sFileName = Dir
Loop
End Sub
There still some mistake in this program. Please help.
Thanks.
Building on #chrisneilsen 's solution, here'a more compact code:
Option Explicit
Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim targetSht As Worksheet
Set targetSht = ActiveWorkbook.Worksheets("Master UTP")
sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)
Do While Len(sFileName) > 0
If sFileName <> targetSht.Parent.Name Then
On Error Resume Next
With Workbooks.Open(sPathName & sFileName)
.Sheets("UTP").Copy After:=targetSht
.Close False
End With
On Error GoTo 0
End If
sFileName = Dir
Loop
End Sub
which should be even slightly more compacted if it can be safely assumed that ActiveWorkbook is a "macro" one, i.e. with a "xlsm" type in its name, so that it can never match any "xls" name:
Option Explicit
Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim targetSht As Worksheet
Set targetSht = ActiveWorkbook.Worksheets("Master UTP")
sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)
Do While Len(sFileName) > 0
On Error Resume Next
With Workbooks.Open(sPathName & sFileName)
.Sheets("UTP").Copy After:=targetSht
.Close False
End With
On Error GoTo 0
sFileName = Dir
Loop
End Sub
Finally, you could appreciate eliminate the flickering at any xls file opening, so you maight enclose the loop inside Application.ScreenUpdating = False/True statements:
Option Explicit
Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim targetSht As Worksheet
Set targetSht = ActiveWorkbook.Worksheets("Master UTP")
sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)
Application.ScreenUpdating = False
Do While Len(sFileName) > 0
On Error Resume Next
With Workbooks.Open(sPathName & sFileName)
.Sheets("UTP").Copy After:=targetSht
.Close False
End With
On Error GoTo 0
sFileName = Dir
Loop
Application.ScreenUpdating = True
End Sub
First issue is you try an open sName rather than sFileName (Use of Option Explicit would detect this error)
Second issue, you are comparing string to a workbook in If sFileName <> sourceWb Then
Third issue, workbook.name doesn't include the path
Your code, refactored, and some error handling added
Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim sourceWb As Workbook, targetWb As Workbook
Dim ws As Worksheet
Set sourceWb = ActiveWorkbook
sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)
Do While Len(sFileName) > 0
If sFileName <> sourceWb.Name Then ' <-- sourceWb.Name does not include path
Set targetWb = Nothing
On Error Resume Next ' <-- in case Open fails
Set targetWb = Workbooks.Open(sPathName & sFileName) '<-- use correct variable sFileName
On Error GoTo 0
If Not targetWb Is Nothing Then
Set ws = Nothing
On Error Resume Next ' <-- in case sheet does not exist
Set ws = targetWb.Worksheets("UTP")
On Error Resume Next
If Not ws Is Nothing Then
ws.Copy After:=sourceWb.Worksheets("Master UTP")
End If
targetWb.Close False
End If
End If
sFileName = Dir
Loop
End Sub
Your code looks fine except for the error where you try and open the other workbooks. You try and open workbooks from the variable sName which is never used. You also reset the sFileName variable needlessly, instead try using sPathName & sFileName as the input for Workbooks.Open().
Also, you try and compare the sFileName to the sourceWb which are two different data types, instead compare sFileName to sourceWb.Name.
Finally, you assume that the workbook will have a worksheet named "UTP", if it doesn't the code will crash. Instead check if the sheet exists first. View https://stackoverflow.com/a/6040390/8520655 for more information.
Please view below for example;
Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim sourceWb As Workbook, targetWb As Workbook
Set sourceWb = ActiveWorkbook
ActiveSheet.Cells(1, 1).Value = sourceWb.Name
sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)
Do While Len(sFileName) > 0
ActiveSheet.Cells(1, 2).Value = sFileName
If sFileName <> sourceWb.Name Then
Set targetWb = Workbooks.Open(sPathName & sFileName)
If SheetExists("UTP", targetWb) Then
targetWb.Sheets("UTP").Copy After:=sourceWb.Sheets("Master UTP")
End If
targetWb.Close
End If
sFileName = Dir
Loop
End Sub
Function SheetExists(SheetName As String, Optional wb As Excel.Workbook)
Dim s As Excel.Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set s = wb.Sheets(SheetName)
On Error GoTo 0
SheetExists = Not s Is Nothing
End Function

Rename sheet while copy to another file

Im using a macro to copy alot of sheets into one excel file. The macro is from an old project so it needs some tweaking. It looks like this:
Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Variant
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = InputBox("Enter a full path to workbooks")
ChDir sPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
wSht = InputBox("Enter a worksheet name to copy")
Do Until sFname = ""
Set wBk = Workbooks.Open(sFname)
Windows(sFname).Activate
Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)
wBk.Close False
sFname = Dir()
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
What I need is a way to rename the sheets that I copy, insted of the sheetname from the original file, I would like it to be renamed into the filename, or add the filename to the sheetname.
Not commenting on your old-macro-code (I personally do not like Windows(sFname).Activate but as far as it works it's ok), this is what to do to change the sheet name:
Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Variant
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = InputBox("Enter a full path to workbooks")
ChDir sPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
wSht = InputBox("Enter a worksheet name to copy")
Do Until sFname = ""
Set wBk = Workbooks.Open(sFname)
Windows(sFname).Activate
Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)
'add this line --v
ThisWorkbook.Sheets(1).Name = "stack" & Replace(Time, ":", "")
'this line is added --^
wBk.Close False
sFname = Dir()
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Note that you would probably have an error, if you are looping too fast once you try to save more than one worksheet, because the name would be the same. Thus, it is a wise idea to introducec a counter for the name.

Copy Active sheet of all workbooks in a folder to a new workbook

Hi I have the following code to copy all worksheets of all workbooks in a given folder to a single workbook. I need to modify this code to copy only the active sheet on all workbooks (now it copies all the sheets). Can you help me with this?
Option Explicit
Sub CombineFiles()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\" 'Change as needed
FileName = Dir(Path & "\*.xlsx", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each WS In Wkb.Worksheets
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next WS
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
This way you can do what you want:
Option Explicit
Sub CombineFiles()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\" 'Change as needed
FileName = Dir(Path & "\*.xlsx", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
ActiveSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'For Each WS In Wkb.Worksheets
' WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'Next WS
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Note:
When you open the workbook, you go over all the sheets with the FOR LOOP, but you only need to copy the ActiveSheet then (as you said) you only need to copy to the new Wrokbook