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
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 have a simple VBA routine I have used before but seem to keep returning Critical_Error 65535 ..this is my routine..it fails at the save part post generating the values only excel file ..any pointers please?
Sub SaveFile()
'Recalc Sheets prior to saving down
a = MsgBox("Do you want to Save down todays Consultant Performance Report ?", vbOKCancel)
If a = 2 Then Exit Sub
Dim SaveSheets As Variant
Dim strFilename As String
Dim sheetListRange As Range
Dim sheetName As Variant
Dim wksheet As Variant
Dim wkbSrc As Workbook
Dim wkbNew As Workbook
Dim wksNew As Worksheet
Dim wksSrc As Worksheet
Dim i As Integer
On Error GoTo ErrorHandler
strFilename = Worksheets("Control").Range("SavePath").Value & "DailyReport_" & Format$(Now(), "YYYYMMDD") & ".xls"
Set sheetListRange = Worksheets("Control").Range("SaveList")
Set wkbSrc = ActiveWorkbook
Set wkbNew = Workbooks.Add
i = 0
For Each sheetName In sheetListRange
If sheetName = "" Then GoTo NEXT_SHEET
For Each wksheet In wkbSrc.Sheets
If wksheet.Name = sheetName Then
i = i + 1
wksheet.Copy Before:=wkbNew.Sheets(i)
Set wksNew = ActiveSheet
With wksNew
.Cells.Select
.Cells.Copy
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
End With
ActiveWindow.Zoom = 75
GoTo NEXT_SHEET
End If
Next wksheet
NEXT_SHEET:
Next sheetName
Application.DisplayAlerts = False
'dont need the default new sheets created by created a new workbook
wkbNew.Worksheets("Sheet1").Delete
wkbNew.Worksheets("Sheet2").Delete
wkbNew.Worksheets("Sheet3").Delete
ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlWorkbookNormal
ActiveWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
'If there is an unknown runtime error give the user the error number and associated description
'(Description is already set if the erorr is G_LNG_CRITICAL_ERROR)
If Err.Number <> CRITICAL_ERROR Then Err.Description = "Run-time error " & Err.Number & ": " & Err.Description
Err.Description = "Error saving worksheet as file: " & Err.Description
'Raise the error up to the error handler above
Err.Raise Number:=CRITICAL_ERROR
End Sub
It started on Monday this week, when I finished with my code,the codes purpose was to pull data from a specific sheet in a specific folder from all spreadsheets in that folder.
But just last night he started crashing excel spreadsheet every time i pushed the run button.
Any idea why?
Option Explicit
Sub ImportSheet()
Dim i As Integer
Dim SourceFolder As String
Dim FileList As Variant
Dim GrabSheet As String
Dim FileType As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Application.EnableEvents = False
SourceFolder = "C:\Users\Jarryd.Ward\Desktop\Test\"
FileType = "*.xlsx"
GrabSheet = "Summary"
FileList = ListFiles(SourceFolder & "/" & FileType)
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
For i = 1 To UBound(FileList)
Workbooks.Open (SourceFolder & "\" & FileList(i))
ImpWorkBk = ActiveWorkbook.Name
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
ActiveWorkbook.Sheets(GrabSheet).Copy After:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)
ActiveSheet.Name = ImpWorkBk
On Error Resume Next
ActiveSheet.Name = FileList(i) & " - " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Workbooks(ActWorkBk).Activate
Next i
Application.ScreenUpdating = True
End Sub
Try opening and closing your files this way to see if it helps. It should minimize the calls to activate this or that. And closing out by variable instead of activesheet will insure that your code isn't trying to close the main workbook by accident.
Sub testOpen()
Dim manyWBs As Workbook
Dim myWB As Workbook
Set myWB = ThisWorkbook
For Each file In folder
Set manyWBs = Workbooks.Open("C:\temp\filename")
' do events.......
manyWBs.Worksheets("Sheet1").Range("A1:B13").Copy _
Destination:=myWB.Worksheets("Sheet1").Range("A1:b13")
manyWBs.Close
Set manyWBs = Nothing
Next file
Set myWB = Nothing
End Sub
I feel like I am close to having my syntax set, but the compile immediately highlights certain lines red showing me they are incorrect, and I do not know how to select a designated cell in VBA. What I want to do is open a template workbook, copy an image form that workbook. Then open all workbooks in a directory, delete an image from sheet1, paste the copied image, delete an image from sheet2 and paste the copied image, save, close, next workbook.
This is my syntax, can someone help me out on what to get this working?
Sub ReplaceImage()
Dim fList() As String, fName As String, fPath As String
Dim intFno As Integer
Dim rngPaste As Range
Dim WB As Workbook, wbOpened As Workbook
Dim strmasterFile As String
Dim shape as Excel.shape
strMasterFile = “C:\Image_Template.xlsx”
Set wbOpened = Workbooks.Open(strmasterFile)
With Sheets(1)
if shape.name = "Picture 1" Then
shape.Select
Selection.Copy
end if
End With
Set WB = ActiveWorkbook
fPath = “C:\NewFormat\” & “\”
If MsgBox(“Collect all sample files in the current dir:” & vbCrLf & fPath, vbYesNo) = vbYes Then
intFno = 0
fName = Dir(fPath & “ * .xlsx”)
While fName <> “”
intFno = intFno + 1
ReDim Preserve fList(1 To intFno)
fList(intFno) = fName
fName = Dir()
Wend
If intFno = 0 Then
MsgBox “No files found”
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For intFno = 1 To UBound(fList)
On Error GoTo Skip
Set wbOpened = Workbooks.Open(fPath & fList(intFno))
With Sheets(1)
For Each shape In ActiveSheet.Shapes
if shape.name = "Picture 19" Then
shape.Delete
end if
next
'Paste Image to Cell A84 and of course it will expand across
End With
With Sheets(2)
For Each shape In ActiveSheet.Shapes
if shape.name = "Picture 6" Then
shape.Delete
end if
next
'Paste Image to Cell A88 and of course it will expand across
End With
wbOpened.Close False
Skip:
Next
Else: End If
End Sub
EDIT --
These are the culprit lines that immediately get font color changed to red
strMasterFile = “C:\Image_Template.xlsx”
fPath = “C:\NewFormat\” & “\”
If MsgBox(“Collect all sample files in the current dir:” & vbCrLf & fPath, vbYesNo) = vbYes Then
MsgBox “No files found”
Removing the smart quotes got rid of the immediate red-liners!!!! Now for my last piece of the pie..how to actually paste the image to the desired cell on each worksheet?
One step close-1st iteration will go issue free, 2nd workbook throws an error of
Paste method of worksheet class failed
On this line
ActiveSheet.Paste
And this is my full-updated code
Sub ReplaceImage()
Dim fList() As String, fName As String, fPath As String
Dim intFno As Integer
Dim rngPaste As Range
Dim WB As Workbook, wbOpened As Workbook
Dim strmasterFile As String
Dim shape As Excel.shape
strmasterFile = "C:\Image_Template.xlsx"
Set wbOpened = Workbooks.Open(strmasterFile)
With Sheets(1)
Rows("1:4").Select
Selection.Copy
End With
Set WB = ActiveWorkbook
fPath = "C:\NewFormat\" & "\"
If MsgBox("Collect all sample files in the current dir:" & vbCrLf & fPath, vbYesNo) = vbYes Then
intFno = 0
fName = Dir(fPath & "*.xlsx")
While fName <> “”
intFno = intFno + 1
ReDim Preserve fList(1 To intFno)
fList(intFno) = fName
fName = Dir()
Wend
If intFno = 0 Then
MsgBox "No files found"
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For intFno = 1 To UBound(fList)
On Error GoTo Skip
Set wbOpened = Workbooks.Open(fPath & fList(intFno))
With Sheets(1)
For Each shape In ActiveSheet.Shapes
If shape.Name = "Picture 19" Then
shape.Delete
End If
Next shape
Rows("84:84").Select
ActiveSheet.Paste
End With
With Sheets(2)
For Each shape In ActiveSheet.Shapes
If shape.Name = "Picture 6" Then
shape.Delete
End If
Next shape
Rows("88:88").Select
ActiveSheet.Paste
End With
Sheets(1).Select
wbOpened.Save
wbOpened.Close False
Skip:
Next
Else: End If
End Sub
Perhaps not the issue, but too long for a comment.
Your With blocks look funky - you're missing the leading period which ties the enclosed child items into the With object.
With Sheets(1)
Rows("1:4").Select '<< defaults to active sheet
Selection.Copy
End With
should be:
With Sheets(1)
.Rows("1:4").Select '<< leading period ties this to Sheets(1)
Selection.Copy
End With
Also:
fPath = “C:\NewFormat\” & “\”
Do you mean to terminate with two backslashes?
This code creates an Excel file with one sheet. This sheet contains the code of an item like (ASR/Floor/Dept./Item_Name/Item_details/1) which I created and works fine, but I want to add a sheet into this Excel file to create another item code, and then save this file.
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim var As Variant
Dim code As String
Dim i, nocode As Integer
Dim fname, heading As String
code = "ASR/" & Text1.Text & "/" & Text2.Text & "/" & Text3.Text & "/" & Text4.Text
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Add ' Create a new WorkBook
Set ws = wb.Worksheets("Sheet1") 'Specify your worksheet name
nocode = txtnocode.Text
heading = Text6.Text
For i = 2 To nocode + 1
ws.Cells(i, 1).Value = code & "/" & i - 1 '"ORG"
Next i
fname = "c:\" & Text5.Text & ".xls"
wb.SaveAs (fname)
wb.Close
xlApp.Quit
Set ws = Nothing
Set wb = Nothing
Set xlApp = Nothing
The Worksheets.Add method is what you are looking for:
wb.WorkSheets.Add().Name = "SecondSheet"
See MSDN(scroll down and expand Sheets and Worksheets) for the different parameters you can give to .Add including being able to add the sheet before or after a specific one.
Set ws = wb.Sheets("Sheet1")
Set ws = wb.Sheets.Add
ws.Activate
This is some standard code I use for this type of problem
Note: This code is VBA, to run from within the Excel document itself
Option Explicit
Private m_sNameOfOutPutWorkSheet_1 As String
Sub Delete_Recreate_TheWorkSheet()
On Error GoTo ErrorHandler
'=========================
Dim strInFrontOfSheetName As String
m_sNameOfOutPutWorkSheet_1 = "Dashboard_1"
strInFrontOfSheetName = "CONTROL" 'create the new worksheet in front of this sheet
'1] Clean up old data if it is still there
GetRidOf_WorkSheet_IfItExists (m_sNameOfOutPutWorkSheet_1)
CreateNewOutputWorkSheet m_sNameOfOutPutWorkSheet_1, strInFrontOfSheetName
'Color the tab of the new worksheet
ActiveWorkbook.Sheets(m_sNameOfOutPutWorkSheet_1).Tab.ColorIndex = 5
'Select the worksheet that I started with
Worksheets(strInFrontOfSheetName).Select
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "One_Main - Error: " & Err.Number & " " & Err.Description
End Select
End Sub
Sub GetRidOf_WorkSheet_IfItExists(sWorkSheetName_ForInitalData As String)
On Error GoTo ErrorHandler
'=========================
If fn_WorkSheetExists(sWorkSheetName_ForInitalData) Then
'Sheet Exists
Application.DisplayAlerts = False
Worksheets(sWorkSheetName_ForInitalData).Delete
Application.DisplayAlerts = True
End If
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "GetRidOf_WorkSheet_IfItExists - Error: " & Err.Number & " " & Err.Description
End Select
End Sub
Function fn_WorkSheetExists(wsName As String) As Boolean
On Error Resume Next
fn_WorkSheetExists = Worksheets(wsName).Name = wsName
End Function
Sub CreateNewOutputWorkSheet(sWorkSheetName_ForOutputData As String, strInFrontOfSheetName As String)
On Error GoTo ErrorHandler
'=========================
If fn_WorkSheetExists(sWorkSheetName_ForOutputData) Then
'Sheet Exists
Application.DisplayAlerts = False
Worksheets(sWorkSheetName_ForOutputData).Delete
Application.DisplayAlerts = True
End If
Dim wsX As Worksheet
Set wsX = Sheets.Add(Before:=Worksheets(strInFrontOfSheetName))
wsX.Name = sWorkSheetName_ForOutputData
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "CreateNewOutputWorkSheet - Error: " & Err.Number & " " & Err.Description
End Select
End Sub