I currently have a list of files with the file path (C:/something.xlxs) in column B of a sheet. I want to write a Macro to read the value from the cell, open the file, and then move on to the next cell and open that file, etc.
I currently have this:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
For i = 1 To 5
If Not IsEmpty(Cells(i, 2)) Then
sFullName = Cells(i, 2).Value
Workbooks.Open fileName:=Cells(i, 2).Value, UpdateLinks:=0
End If
Next i
End Sub
It is only opening the first file from the list and then stopping. It is probably a small error but I am having trouble spotting it.
Thanks
I would do it this way:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
Dim wsh As Worksheet
On Error GoTo Err_openFiles
Set wsh = ThisWorkbook.Worksheets("Sheet1")
i = 1
Do While wsh.Range("B" & i)<>""
sFullName = wsh.Range("B" & i)
Application.Workbooks.Open sFullName, UpdateLinks:=False
i = i+1
Loop
Exit_openFiles:
On Error Resume Next
Set wsh = Nothing
Exit Sub
Err_openFiles:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_openFiles
End Sub
Above code works in context and provides a way to handle errors.
Try
Dim wb As Excel.Workbook
Set wb = Workbooks.Open(Filename:=sFullName)
Related
I have 27 txt files with the same format and columns, and I want to append all of these in a single excel sheet. I have checked some previous threads here, but I could only find the code below which helped me to import txt fiels into separate sheets. However, I also want to append these separate sheets into a sheet that I want to append all my data.
Sub Test()
'UpdatebyExtendoffice6/7/2016
Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Vendor_data_25DEC]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath)
'xFile = Dir(xStrPath & "*.txt") 'this is the original version that you can amend according to file extension
If xFile = "" Then
MsgBox "No files found", vbInformation, "Vendor_data_25DEC"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Set xToBook = ThisWorkbook
If xFiles.Count > 0 Then
For I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
On Error GoTo 0
xWb.Close False
Next
End If
End Sub
I am not sure how to do this with VBA in order to combine the data in separate sheets into a single sheet quickly. I know the consolidate feature of excel but it also includes lots of manual steps, so I seek for a faster and automated solution. Any help is much appreciated.
Thanks a lot in advance.
Sub Combiner()
Dim strTextFilePath$, strFolder$
Dim wksTarget As Worksheet
Dim wksSource As Worksheet
Dim x As Long
Set wksTarget = Sheets.Add()
strFolder = "c:\Temp\test\"
strTextFilePath = Dir(strFolder)
While Len(strTextFilePath) > 0
'// "x" variable is just a counter.
'// It's purpose is to track whether the iteration is first or not.
'// If iteration is first (x=1), then we include header (zero offset down),
'// otherwise - we make an offset (1 row offset down).
x = x + 1
Set wksSource = Workbooks.Open(strFolder & strTextFilePath).Sheets(1)
With wksTarget
wksSource.Range("A1").CurrentRegion.Offset(IIf(x = 1, 0, 1)).Copy _
.Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
wksSource.Parent.Close False
strTextFilePath = Dir()
Wend
MsgBox "Well done!", vbInformation
End Sub
I tried to create VBA macro in excel where one excel sheet tracks a path and creates a new tab in another sheet. It works well but when I create another tab "accidentally" with same name it gives me error as "Name already taken try another one". I don't want to create one more tab with same name. Instead it should stop me from creating tabs with same name
Is there anyway if there that name already exist it gives me a pop up saying name already exist I get only one option as ok to click. I click Ok and the additional sheet that is created doesn't get saved (or if already created deletes itself or save as same name with (2) next to it as excel usually do for repeated sheets). I am trying something like this
If wb.ActiveSheet.Name = sName Then wb.ActiveSheet.Delete
Here is my code
Private Sub Filling_List()
Dim sPath As String
Dim sFile As String
Dim wb As Workbook
Dim sName As String 'add sName declaration
Dim wb1 As Workbook
Dim ws1 As Worksheet
Set wb1 = ThisWorkbook
Set ws1 = ThisWorkbook.Worksheets("S0")
Application.ScreenUpdating = False
sPath = "C:\Users\arp\Desktop\Filling list macro\"
sFile = sPath & "ArF Filling List.xlsm"
Set wb = Workbooks.Open(sFile)
wb.Worksheets("ArF Templete").Copy After:=Worksheets(Worksheets.Count)
sName = ws1.Range("A1") & " " & ws1.Range("T2")
wb.ActiveSheet.Name = sName
'If wb.ActiveSheet.Name = sName Then wb.ActiveSheet.Delete "I am trying this but it doesn't work"
If sName = vbNullString Then Exit Sub 'compare against vbNullstring not empty string literal
With wb.Worksheets(sName)
.Cells(3, "E") = InputBox("Your Initials:")
'.Cells(5, "E") = InputBox("Col?:")
.Cells(6, "E") = InputBox("I:")
.Cells(7, "E") = InputBox("ET1 B:")
.Range("B03") = wb1.Worksheets("Que").Range("B02").Value2
.Range("B04") = wb1.Worksheets("Que").Range("E01").Value2
.Range("B05") = wb1.Worksheets("Que").Range("B01").Value2
.Cells(3, "E") = wb1.Worksheets("Que").Range("E02").Value2
.Cells(5, "E") = "Yes"
'Filling order
.Range("B38:B43") = wb1.Worksheets("Que & Tsc Cal").Range("B04:B09").Value2
.Range("C38:C43") = wb1.Worksheets("Que & Tsc Cal").Range("C04:C09").Value2
.Range("D38:D43") = wb1.Worksheets("Que & Tsc Cal").Range("A04:A09").Value2
'Retains
End With
Application.ScreenUpdating = True
End Sub
I developed above version with the help of you guys here and joining bits and pieces from other threads.Any suggestions to make it better are very welcome.
I use a check if the named tab/sheet is available:
If IsError(Evaluate("SHEETNAME!A1")) Then
'Nothing
Else
Sheets("SHEETNAME").Delete
End If
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "SHEETNAME"
Or as suggested by Scott to have it be simpler and cleaner:
If Not IsError(Evaluate("SHEETNAME!A1")) Then Sheets("SHEETNAME").Delete
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "SHEETNAME"
Edit 1:
Application.DisplayAlerts = False
If IsError(Evaluate("SHEETNAME!A1")) Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "SHEETNAME"
Application.DisplayAlerts = True
[W]hen I create another tab "accidentally" with same name it gives me error . . . I don't want to create one more tab with same name. Instead it should stop me from creating tabs with same name
This is not an uncommon problem with macros that create tabs--it is easy to accidentally run them twice. To prevent this, first check to see if the tab already exists and only after verifying that it doesn't exist, call the Worksheets.Copy method.
Private Sub Filling_List()
Dim sPath As String
Dim sFile As String
Dim wb As Workbook
Dim sName As String 'add sName declaration
Dim wb1 As Workbook
Dim ws1 As Worksheet
Set wb1 = ThisWorkbook
Set ws1 = ThisWorkbook.Worksheets("S0")
Application.ScreenUpdating = False
sPath = "C:\Users\arp\Desktop\Filling list macro\"
sFile = sPath & "ArF Filling List.xlsm"
Set wb = Workbooks.Open(sFile)
sName = ws1.Range("A1") & " " & ws1.Range("T2")
On Error Resume Next
Dim wslTest As Worksheet
Set wslTest = wb.Worksheets(sName)
If Err.Number = 0 Then
MsgBox "Tab: " & sName & " already exists.", vbInformation
wslTest.Activate
Exit Sub
End If
On Error GoTo 0
wb.Worksheets("ArF Templete").Copy After:=wb.Worksheets(wb.Worksheets.Count)
wb.ActiveSheet.Name = sName
' rest of code
End Sub
The code below should do what you want, you may need to adapt it for your project.
Option Explicit
Sub addsheet()
Dim sht As Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets.add
On Error Resume Next 'Prevent Excel from stopping on an error but just goes to next line
ws.Name = "Sheet1"
If Err.Number = 1004 Then
MsgBox "Worksheet with this name already exists"
Application.DisplayAlerts = False 'Prevent confirmation popup on sheet deletion
ws.Delete
Application.DisplayAlerts = True 'Turn alerts back on
On Error GoTo 0 'Stop excel from skipping errors
Exit Sub 'Terminate sub after a failed attempt to add sheet
End If
On Error GoTo 0 'Stop Excel from skipping errors.
End Sub
I try to merge workbooks from a folder in a new workbooks. The VBA code reads the excel file from folder, add every file name to a list box and then, after pressing the button "Start", add very file to the workbook. That is the idea.
The code is as folows:
When opening the file the userform is shown:
Private Sub Workbook_Open()
UserForm1.Show
End Sub
When activating userform, the list box is populated:
Private Sub UserForm_Activate()
Const strFolder As String = "C:\Users\user\Desktop\tmp\"
Const strPattern As String = "*.xls"
Dim strFile As String
Dim collection As New collection
Dim i As Integer
Dim isMerger As Integer
Dim lngth As Integer
strFile = Dir(strFolder & strPattern, vbNormal)
If (StrComp(strFile, "FileMerger.xls") <> 0) Then
If (Len(strFile) <> 0) Then
col.Add (strFolder & strFile)
Do While Len(strFile) > 0
strFile = Dir
If (StrComp(strFile, "FileMerger.xls") <> 0) Then
If (Len(strFile) <> 0) Then
col.Add (strFolder & strFile)
End If
End If
Loop
End If
End If
Vars.xlsFiles = ColToArray(collection)
For i = 1 To UBound(Vars.xlsFiles)
lstFiles.AddItem (Vars.xlsFiles(i))
Next i
End Sub
At this moment listbox and array Vars.xlsFiles are populated; they are OK.
Click on Start button in the userform:
Private Sub cmdStart_Click()
Dim fileName As String
Dim sheet As Worksheet
Dim i As Integer
Dim ub As Integer
ub = UBound(Vars.xlsFiles)
For i = 1 To ub
Workbooks.Open fileName:=Vars.xlsFiles(i), ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
Next i
End Sub
In the folder are 3 files. Their name are in the listbox. But when the first is to be closed I received an error message and after debugging it says that fileName ="" (line Workbooks(fileName).Close).
whatever I try I got the same error, i.e. fileName = "".
What to do ?
Your never set the variable fileName, so it's still the default value "". Maybe you got confused by the fileName:=Vars.xlsFiles(i) of the Workbooks.Open method. That just sets the option FileName of that method. Use some unique name to avoid confusion and set it to Vars.xlsFiles(i) or use
Workbooks(Vars.xlsFiles(i)).close
FileName:= is a named parameter of the Workbooks.Open method. It does not set the value of the cmdStart_Click's fileName variable.
Private Sub cmdStart_Click()
Dim fileName As String
Dim sheet As Worksheet
Dim i As Integer
Dim ub As Integer
ub = UBound(Vars.xlsFiles)
For i = 1 To ub
fileName = Vars.xlsFiles(i)
Workbooks.Open FileName:=fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
Next i
End Sub
After much struggle with syntax, I have following code working, but I want to use error checking to determine if file is already open using a string.
(Disclosure: I have copied comparesheets from source that I will link when I find it)
Trying to replace this code
Set wbkA = Workbooks.Open(FileName:=wba)
with
Set wBook = Workbooks(wba) 'run time error subscript out of range
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(FileName:=wba)
End If
But I have syntax problem with the string wba. What is proper way use string here?
Sub RunCompare_WS2()
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wBook As Workbook
wba = "C:\c.xlsm"
wbb = "C:\d.xlsm"
'Set wBook = Workbooks(FileName:=wba) 'compiler error named argument not found
'Set wBook = Workbooks(wba) 'run time error subscript out of range
'If wBook Is Nothing Then
'Set wbkA = Workbooks.Open(FileName:=wba)
'End If
Set wbkA = Workbooks.Open(FileName:=wba)
Set wbkB = Workbooks.Open(FileName:=wbb)
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\comp-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
You can use On Error Resume Next to ignore any error:
Const d As String = "C:\"
wba = "c.xlsm"
On Error Resume Next
Set wBook = Workbooks(wba)
On Error Goto 0
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(d & wba) 'join string d & wba
End If
This will check to see if you have the file open.
Option Explicit
Function InputOpenChecker(InputFilePath) As Boolean
Dim WB As Workbook
Dim StrFileName As String
Dim GetFileName As String
Dim IsFileOpen As Boolean
InputOpenChecker = False
'Set Full path and name of file to check if already opened.
GetFileName = Dir(InputFilePath)
StrFileName = InputFilePath & GetFileName
IsFileOpen = False
For Each WB In Application.Workbooks
If WB.Name = GetFileName Then
IsFileOpen = True
Exit For
End If
Next WB
If you dont have it open, check to see if someone else does.
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open StrFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
'Set the FileLocked Boolean value to true
FileLocked = True
Err.Clear
End If
And one reason for your error could be the inclusion of "FileName:=" in the Workbooks.Open. Try;
Set wbkA = Workbooks.Open(wba)
Set wbkB = Workbooks.Open(wbb)
Fixed my code and reposting with corrections for clarity.
Note I moved to C:\temp since writing to root C:\ folder should not be used because many work computers have root folder locked for security as my colleague just found out!
Sub RunCompare_WS9() 'compare two WKbooks, all sheets write diff to text file
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wbook1 As Workbook
Dim wbook2 As Workbook
wba = "C:\test\c.xlsm"
wbb = "C:\test\d.xlsm"
On Error Resume Next
Set wbook1 = Workbooks(wba)
On Error GoTo 0
If wbook1 Is Nothing Then
Set wbkA = Workbooks.Open(wba)
End If
On Error Resume Next
Set wbook2 = Workbooks(wbb)
On Error GoTo 0
If wbook2 Is Nothing Then
Set wbkB = Workbooks.Open(wbb)
End If
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\Test\comp2-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
I have a button in my GUI which calls this procedure:
Private Sub CommandButtonPersonalFilter_Click()
Unload GUI
Dim myPath As String
Dim Wb As Workbook
myPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)
If Dir(myPath & "\filterPartsList.xlsx") = "" Then
FileCopy "Z:\Dokumentstyring\Templates\filterPartsList.xlsx", myPath & "\filterPartsList.xlsx"
End If
Set Wb = HelpFunctions.GetWorkbook(myPath & "\filterPartsList.xlsx")
Wb.Activate
Wb.Sheets(1).Range("A1").Select
Set Wb = Nothing
End Sub
When I click the button(from a.xlsx) it opens up a new workbook(b.xlsx, all as it should), but if I then decide that the b.xlsx is just fine and I would like to close b.xlsx (or edit), then I am only allowed to do so if I first jump back to a.xlsx, click on any cell there and then jump back to the b.xlsx
Below is the helper function:
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String
Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Workbooks.Open(sFullName)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
Not a big issue but would be nice to figure out where the problem might be. All macros are stored in personal.xlsb