I have split the directory in column A and filename in Column B. Trying to loop a macro to open all the files in the columns.
Using the codes below, it opens only the first file. not sure where I had gone wrong. the codes are as below:
Sub openfiles()
Dim directory As String, fileName As String, sheet As Worksheet, i As Integer, j As Integer
Dim wb As Workbook
Dim path As Worksheet
Dim row As String
Set wb = ThisWorkbook
Set path = wb.Sheets("sheet1")
row = 2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = path.Range("A" & CStr(row))
fileName = Dir(directory & path.Range("B" & CStr(row)))
Do While fileName <> ""
Workbooks.Open (directory & Dir(directory & path.Range("B" & CStr(row))))
row = row + 1
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
After running, I would except all the files to be open so that I can proceed with other macros.
update:
here's the screenshot as requested, I can do with the directory and filename in one column.
Try this:
I prefer using this simple Method in case I already have all the file list in Excel.
Option Explicit
Sub openfiles()
Dim i As Long
Dim wb As Workbook
Dim path As Worksheet
Set wb = ThisWorkbook
Set path = wb.Sheets("sheet1")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To path.Range("A2").End(xlDown).row
If Len(Dir(path.Range("A" & i) & path.Range("B" & i))) > 0 Then
Workbooks.Open (path.Range("A" & i) & path.Range("B" & i))
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Moving on to your code:
I usually resort to this method when I have to open all the files in a Particular folder or I don't have the Name of the File. Because this way you can pass on a Wildcard. So if you want to open all the Workbooks of folder O:\Common\ use this:
Sub openfiles()
Dim directory As String, fileName As String, sheet As Worksheet, i As Integer, j As Integer
Dim wb As Workbook
Dim path As Worksheet
Dim row As String
Set wb = ThisWorkbook
Set path = wb.Sheets("sheet1")
row = 2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = path.Range("A" & CStr(row))
fileName = Dir(directory & "*.*")
Do While fileName <> ""
Workbooks.Open (directory & fileName)
row = row + 1
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Problem: the problem with your code was, you were passing a Specific File Name to the variable filename, that's why you were only getting one file.
You still want to use your code, Here it is without DIR, unused variables and a bit less complicated.
Sub openfiles()
Dim directory As String
Dim fileName As String
Dim row As String
Set path = ThisWorkbook.Sheets("sheet1")
row = 2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = path.Range("A" & CStr(row))
fileName = path.Range("B" & CStr(row))
Do While fileName <> vbNullString
Workbooks.Open (directory & "\" & fileName)
row = row + 1
directory = path.Range("A" & CStr(row))
fileName = path.Range("B" & CStr(row))
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Related
Loop in folder is work, but don't work loop cells, don't work copy and paste selected data from 50 Excel workbooks to a single destination Excel workbook. I work in Windows Operating System. I have folder with 50 Excel files. I have single destiny Excel file. Data go from folder to 1 single Excel file.
Help, please.
Sub Combine()
Dim s As String, MyFiles As String
Dim endd As Integer, startt As Integer
Dim NewWb As Workbook
Dim newS As Worksheet
Dim i As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set NewWb = Workbooks.Add
With NewWb
Set newS = NewWb.Worksheets("Лист1")
End With
endd = i * 10 + 1
startt = endd - 10
MyFiles = "C:\Users\User\Desktop\Nezavisimai\Papka2\"
s = Dir(MyFiles & "*.xlsx")
Do While s <> ""
[a1] = 0
If Dir = "" Then Exit Sub Else i = 1
Do
If Dir = "" Then Exit Do Else i = i + 1
Loop Until False
[a1] = i
With Workbooks.Open(MyFiles & s)
.Worksheets("Данные").Range("A1:C10").Copy
.Close SaveChanges:=False
End With
newS.Select
With newS
.Range("B" & startt & ":D" & endd).Paste
End With
s = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub Combine()
Const FOLDER = "C:\Users\User\Desktop\Nezavisimai\Papka2\"
Dim wb As Workbook, wbNew As Workbook, wsNew As Worksheet
Dim filename As String, i As Long, n As Integer, rng As Range
Set wbNew = Workbooks.Add(xlWBATWorksheet) '1 sheet
Set wsNew = wbNew.Sheets(1)
Application.ScreenUpdating = False
i = 1
filename = Dir(FOLDER & "*.xlsx")
Do While filename <> ""
' open book and copy range
Set wb = Workbooks.Open(FOLDER & filename, False, True) ' no link update, read only
Set rng = wb.Sheets(1).Range("A1:C10")
rng.Copy wsNew.Range("B" & i)
i = i + rng.Rows.Count
' close book goto next
wb.Close False
n = n + 1
filename = Dir
Loop
' save combined
wbNew.SaveAs ThisWorkbook.Path & "\Combined.xlsx"
wbNew.Close False
Application.ScreenUpdating = True
MsgBox n & " files copied", vbInformation
End Sub
I have 99 workbooks in a folder. I want to copy sheet1 from each into a new workbook. It doesn't matter what order as long as each workbook/sheet1 goes onto a new worksheet in the destination workbook.
I have written a code, and tried to sample other codes. No matter what it will only copy sheet1 of the first 10 workbooks.
How can this work on all the workbooks in the folder? My goal is to get the sheets together so I can merge certain cells into a summary sheet.
I put this code into a module on my destination workbook.
Sub combineWorkbooks()
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*.xls") Do While fileName <> ""
Workbooks.Open fileName:=Path & fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
fileName = Dir() Loop
End Sub
EDIT: this should prevent any issues trying to copy multiple sheets with the same name into the workbook.
Sub combineWorkbooks()
Dim Path, fileName, sheetNum As Long, sheetName As String
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*.xls")
Do While fileName <> ""
With Workbooks.Open(fileName:=Path & fileName, ReadOnly:=True)
sheetName = .Worksheets(1).Name
sheetNum = 1
'if a worksheet with the same name already exists, add
' an incrementing number until the name is unique
If WorksheetExists(sheetName) Then
Do While WorksheetExists(sheetName & sheetNum)
sheetNum = sheetNum + 1
Loop
.Worksheets(1).Name = sheetName & sheetNum 'rename if required
End If
'copy to end of sheets
.Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Close
End With
fileName = Dir()
Loop
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
If you're still getting only 10 files then maybe it's an issue with the file names/extensions?
Edit - try listing all of the files:
Dim Path, fileName
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*")
Do While fileName <> ""
Debug.Print fileName
fileName = Dir()
Loop
What output do you get?
It was a file name extension, as you thought.
I now have this working.
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:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0800-JJ0899" '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
I am stuck with the following problem and need some help:
I am trying to paste the first column of every excelfile of a folder into one excelsheet so that the first column is in column A and the second in column B and so on. The columns are always in the first sheet in every workbook.
Here is what i have right now:
Sub OpenFiles()
Const FILE_PATH As String = "C:\Users\"
Dim MyFile As String
Dim objWorkbook As Workbook
Dim c As Integer
Dim destWb As Workbook
c = 1
Application.ScreenUpdating = False
MyFile = Dir$(FILE_PATH & "*.xlsx")
Set destWb = Workbooks.Open("C:\Users\Translations.xlsx")
Do Until MyFile = ""
Set objWorkbook = Workbooks.Open(Filename:=FILE_PATH & MyFile, UpdateLinks:=3)
objWorkbook.Worksheets(1).Range("A1:A100").Copy _
destWb.Worksheets(1).Range(destWb.Worksheets(1).Cells(1, c)).Paste
c = c + 1
Call objWorkbook.Close(SaveChanges:=True)
MyFile = Dir$
Loop
Application.ScreenUpdating = True
End Sub
it can't figure out how to copy and paste from the one Workbook to the other
Thanks for your help,
Valentin
I used your vba script and modified a bit to test on my pc. Copy and paste often cause error. And your script destWb.Worksheets(1).Range(destWb.Worksheets(1).Cells(1, c)).Paste looks buggy. Here is my modified script that works perfectly.
Sub OpenFiles()
Const FILE_PATH As String = "C:\Users\***\Desktop\vba_test\"
Dim MyFile As String
Dim objWorkbook As Workbook
Dim c As Integer
Dim i As Integer
Dim destWb As Workbook
c = 1
Application.ScreenUpdating = False
MyFile = Dir$(FILE_PATH & "*.xlsx")
Set destWb = Workbooks.Open("C:\Users\***\Desktop\dest.xlsx")
Do Until MyFile = ""
Set objWb = Workbooks.Open(FILE_PATH & MyFile, True, True)
For i = 1 To 20
destWb.Worksheets(1).Cells(1, c).Offset(i - 1, 0).Value = objWb.Worksheets(1).Range("A" & i).Value
Next i
c = c + 1
Call objWb.Close(SaveChanges:=False)
Set objWb = Nothing
MyFile = Dir$
Loop
Application.ScreenUpdating = True
End Sub
I want to open a workbook that contains only one sheet,
copy data up to column AC until last available row in column A,
paste the data into first empty row in column A in workbook "Mergedsheet.xlsx".
I want to loop over all workbooks present in a specific folder, but get lots of errors.
Sub MergeNew()
Dim WorkBk As Workbook
Dim MergedSheet As Worksheet
Dim SourceData As Range
Dim DestinationData As Range
Dim lastRow As Long
Dim NextRow As Range
Dim FolderPath As String
Dim FileNames As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FolderPath = "E:\Jan to March 2019\Bharuch 31\"
FileNames = Dir(FolderPath & "*.xls*")
Do While FileNames <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileNames)
Range("A1:AC1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Open Filename:="E:\Jan to March 2019\Bharuch 31\MergedSheet.xlsx"
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastRow).Select
ActiveSheet.Paste
'ActiveWindow.Close SaveChanges:=True
'ActiveWindow.Close SaveChanges:=False
Application.CutCopyMode = False
FileNames = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You are looping through a folder and copy-pasting each workbook's first sheet's data to workbook A. However, workbook A is also in that folder. So you should take care to skip it (when looping).
(Alternatively, you could provide a different argument to the DIR function (e.g. some wildcard criteria that excludes workbook A if possible), so that you don't have to constantly check inside the loop.)
Untested.
Option Explicit
Private Sub MergeNew()
'Application.ScreenUpdating = False 'Uncomment this when you know code is working.
'Application.DisplayAlerts = False 'Uncomment this when you know code is working.
Dim folderPath As String
folderPath = GetFolderPath(titleToShow:="Select the folder containing the files to loop through.")
Dim Filename As String
Filename = Dir$(folderPath & "*.xls*")
If Len(Filename) = 0 Then
MsgBox "Could not find a relevant file in '" & folderPath & "'. Code will stop running now."
Exit Sub ' No point in carrying on in such a case.
End If
Dim destinationFolderPath As String
destinationFolderPath = GetFolderPath(titleToShow:="Select the folder to save the 'MergedSheet.xlsx' file to.")
Dim destinationWorkbook As Workbook
Set destinationWorkbook = Application.Workbooks.Add
' This line may throw an error
destinationWorkbook.SaveAs Filename:=destinationFolderPath & "MergedSheet.xlsx", FileFormat:=xlOpenXMLWorkbook
Dim destinationSheet As Worksheet
Set destinationSheet = destinationWorkbook.Worksheets(1) ' I assume there's only 1 sheet in there, but change as necessary.
Do Until Len(Filename) = 0
Dim fullFilePathToOpen As String
fullFilePathToOpen = folderPath & Filename
If fullFilePathToOpen <> destinationWorkbook.FullName Then ' Probably could have just compared filename since directory is the same, but this is more explicit
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Application.Workbooks.Open(Filename:=fullFilePathToOpen, ReadOnly:=True) ' If you don't make changes to the workbook you open, better to open as read-only
Dim sourceSheet As Worksheet
Set sourceSheet = sourceWorkbook.Worksheets(1) ' You say there's only one worksheet in there, so referring by index should be okay (for now)
Dim lastSourceRow As Long
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row ' Assume last row can be determined from column A alone
Dim lastDestinationRow As Long
lastDestinationRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row + 1
If destinationSheet.Rows.Count < (lastDestinationRow + lastSourceRow) Then
MsgBox "Ran out of rows (in sheet '" & sourceSheet.Name & "' of workbook '" & destinationWorkbook.Name & "')"
Exit Sub
End If
sourceSheet.Range("A1", sourceSheet.Cells(lastSourceRow, "AC")).Copy Destination:=destinationSheet.Cells(lastDestinationRow, "A")
sourceWorkbook.Close False
End If
Filename = Dir$()
Loop
'Application.ScreenUpdating = True 'Uncomment this when you know code is working.
'Application.DisplayAlerts = True 'Uncomment this when you know code is working.
End Sub
Private Function GetFolderPath(Optional ByVal titleToShow As String = vbNullString) As String
With Application.FileDialog(msoFileDialogFolderPicker)
If Len(titleToShow) > 0 Then .Title = titleToShow
.AllowMultiSelect = False ' Only one is allowed.
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Folder selection appears to have cancelled. Code will stop running now"
End
End If
GetFolderPath = .SelectedItems(1) & "\"
End With
End Function
I have a macro I'm trying to run on multiple workbooks within the same folder. I currently have the following, but when I run it (by using F5 in VBA for excel), nothing happens. The excel VBA window simply flickers, but none of the workbooks, even the first one, is affected by the macro. If it helps, sometimes F5 asks me to confirm that I'm running "Sheet1.DoAllFiles." I'm very beginner, so I'm sure it's something simple I'm missing - but any help in getting this program to loop would be appreciated. Thanks!
The looping code I found:
Sub DoAllFiles()
Dim Filename, Pathname As String
Dim WB As Workbook
'Pathname = "G:\Google Drive\2013-2014\Testingbeforedeployment"
'One pathname is coded out depending on what computer I'm running it from
Pathname = "C:\Users\Maptop\Google Drive\2013-2014\Testingbeforedeployment"
Filename = Dir(Pathname & "\*.xls*")
Do While Filename <> ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Do While Filename <> ""
Set WB = Workbooks.Open(Pathname & "\" & Filename) 'open all files
Call Simplify(WB)
WB.Close SaveChanges:=True
Set WB = Nothing
Filename = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Loop
End Sub
The macro that my loop should be calling:
Private Sub Simplify(WB As Workbook)
Sheets.Add After:=Sheets(Sheets.Count)
Const tlh As String = "Credited"
With Sheets("Inventory") 'Change to suit
Dim tl As Range, bl As Range
Dim first_add As String, tbl_loc As Variant
Set tl = .Cells.Find(tlh)
If Not tl Is Nothing Then
first_add = tl.Address
Else
MsgBox "Table does not exist.": Exit Sub
End If
Do
If Not IsArray(tbl_loc) Then
tbl_loc = Array(tl.Address)
Else
ReDim Preserve tbl_loc(UBound(tbl_loc) + 1)
tbl_loc(UBound(tbl_loc)) = tl.Address
End If
Set tl = .Cells.FindNext(tl)
Loop While tl.Address <> first_add
Dim i As Long, lrow As Long, tb_cnt As Long: tb_cnt = 0
For i = LBound(tbl_loc) To UBound(tbl_loc)
Set bl = .Cells.Find(vbNullString, .Range(tbl_loc(i)) _
, , , xlByColumns, xlNext)
lrow = Sheets("Sheet1").Range("A" & _
Sheets("Sheet1").Rows.Count).End(xlUp).Row
.Range(.Range(tbl_loc(i)).Offset(0, 3)(IIf(tb_cnt <> 0, 1, 0), 0), _
bl.Offset(-1, 0)).Resize(, 9).Copy _
Sheets("Sheet1").Range("A" & lrow).Offset(IIf(lrow = 1, 0, 1), 0)
tb_cnt = tb_cnt + 1
Set bl = Nothing
Next
End With
End Sub
You have an extra Do While...Loop in there...
Sub DoAllFiles()
Dim Filename, Pathname As String
Dim WB As Workbook
'Pathname = "G:\Google Drive\2013-2014\Testingbeforedeployment"
Pathname = "C:\Users\Maptop\Google Drive\2013-2014\Testingbeforedeployment"
Filename = Dir(Pathname & "\*.xls*")
Do While Filename <> ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WB = Workbooks.Open(Pathname & "\" & Filename) 'open all files
Simplify WB '<<<EDIT
WB.Close SaveChanges:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Filename = Dir()
Loop
End Sub
In your Simplify() Sub you don't ever seem to reference WB, and all your Sheets references have no Workbook qualifier: by default they will reference the ActiveWorkbook, but you shouldn't rely on that. From your code it's not clear whether you intend to reference sheets in WB or in the workbook containing the code.