I am relatively new to Visual Basic. I have VB macro code which searches files based on user selection using drop down menu and returns the value.
Below is the code snippet:
Sub GetDataFromClosedBook()
Dim mydata As String
Dim mydata1 As String
Dim wkb As Workbook
Dim wkb1 As Workbook
Application.EnableEvents = False
Application.ScreenUpdating = False
Sheets("Sheet1").Visible = True
Sheets("Sheet1").Select
' I need to add if else loop here,
' when 'mydata' is not found jump to 'mydata1'
' and return the value
mydata = "C:\Users\Desktop\Test\" & Range("A1") & Range("A2") & Range("A3") & Range("A4") & ".csv"
Set wkb = Workbooks.Open(mydata)
wkb.Sheets(1).Range("A1").Copy ThisWorkbook.Sheets("Sheet1").Range("C1")
wkb.Close False
mydata1 = "C:\Users\Desktop\Test\" & Range("B1") & Range("B2") & Range("B3") & Range("B4") & ".csv"
Set wkb1 = Workbooks.Open(mydata1)
wkb1.Sheets(1).Range("A1").Copy ThisWorkbook.Sheets("Sheet1").Range("C2")
wkb1.Close False
Sheets("Sheet1").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Any help would be greatly appreciated!!
mydata = "C:\Users\Desktop\Test\" & Range("A1") & Range("A2") & Range ("A3") & Range("A4") & ".csv"
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(mydata)) Then
Set wkb = Workbooks.Open(mydata)
wkb.Sheets(1).Range("A1").Copy
ThisWorkbook.Sheets("Sheet1").Range("C1")
wkb.Close False
else
mydata1 = "C:\Users\Desktop\Test\" & Range("B1") & Range("B2") & Range("B3") & Range("B4") & ".csv"
Set wkb1 = Workbooks.Open(mydata1)
wkb1.Sheets(1).Range("A1").Copy
ThisWorkbook.Sheets("Sheet1").Range("C2")
wkb1.Close False
end if
Sheets("Sheet1").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
I found another way to retrieve files based on dropdown selection Using Do while loop.
Here is the code Snippet.
Do While Filename <> ""
On Error Resume Next
Set wkb = Workbooks.Open(mydata & Filename)
wkb.Sheets(1).Range("D8").Copy ThisWorkbook.Sheets("Sheet1").Range("H6")
wkb.Close False
If Err.Number <> 0 Then
MsgBox ("Unable to open file " & Filename)
Err.Clear
End If
On Error GoTo 0
Exit Do
Filename = Dir
Loop
Related
I would like to modify the following code so that two things happen:
1) The user is able to select the csv's they want in a folder
2)Keep the header for the first csv only and keep the body for the rest of Csvs
How would I go about this in the following code? I keep receiving an error currently when I run this code.
Sub ImportCSVsWithReference()
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
xFileDialog.AllowMultiSelect = True
xFileDialog.Title = "Select a folder [CSV Consolidation]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo) = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
Columns(1).Insert xlShiftToRight
Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Range("A1:R1").Select
Selection.AutoFilter
Range("L1").AutoFilter Field:=12, Criteria1:="<>"
Selection.End(xlToLeft).Select
Range("A1").CurrentRegion.Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Exit Sub
ErrHandler:
MsgBox "no files csv", , "Team"
End Sub
Here is a little starter for you.
It grab files without your error and then you can do what you want.
Sub ImportCSVsWithReference()
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
xFileDialog.AllowMultiSelect = True
xFileDialog.Title = "Select a folder [CSV Consolidation]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = ThisWorkbook.ActiveSheet
If MsgBox("Clear the existing sheet before importing?", vbYesNo) = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
Dim vrtSelectedItem As Variant
Set xWb = Workbooks.Open(xStrPath)
MsgBox "Opened " & xStrPath & " for headers"
'Do your work with headers here with xWb as workbook with code
xWb.Close False
For Each vrtSelectedItem In xFileDialog.SelectedItems
Set xWb = Workbooks.Open(vrtSelectedItem)
MsgBox "Opened " & vrtSelectedItem & " for content"
'Do your work with content here with xWb as workbook with code
xWb.Close False
Next
Application.ScreenUpdating = True
End Sub
I have the following VBA code saving workbook1 sheets to a folder where workbook1 file is saved. Example: workbook1 has 31 sheets. The code saves each sheet to a new workbook with the same name as the sheet. (Sheet1, Sheet2, etc).
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
I need to modify the code to save the file with the ID and date. The ID is in cell A1. "XXX Clinic Pro Fees Report for Doe, John (JDOE)". In this example I need the new workbook to save as JDOE_2017-10-20.
Is there a way to gave the ID and place the date after it?
Try the below code
Sub SaveShtsAsBook()
Dim ldate As String
Dim SheetName1 As String
ldate = Format(Now(), "yyyy-mm-dd")
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
SheetName1 = Range(A1).Value2 & ldate
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
tempstr = Cells(1, 1).Value2
openingParen = InStr(tempstr, "(")
closingParen = InStr(tempstr, ")")
SheetName1 = Mid(tempstr, openingParen + 1, closingParen - openingParen - 1) & "_" & ldate
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName1 & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
You can extract the name code from within the brackets and append the date with a couple lines of code.
SheetName = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
SheetName = sn & Format(Date, "_yyyy-mm-dd")
Along with a couple other modifications as,
Option Explicit
Sub SaveShtsAsBook()
Dim ws As Worksheet, sn As String, mfp As String, n As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error Resume Next '<< a folder exists
mfp = ActiveWorkbook.Path & "\" & Split(ThisWorkbook.Name, Chr(46))(0)
MkDir mfp '<< create a folder
On Error GoTo 0 '<< resume default error handling
With ActiveWorkbook
For n = 1 To .Worksheets.Count
With .Worksheets(n)
sn = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
sn = sn & Format(Date, "_yyyy-mm-dd")
.Copy
With ActiveWorkbook
'save book in this folder
.SaveAs Filename:=mfp & "\" & sn, FileFormat:=xlExcel8
.Close SaveChanges:=False
End With
End With
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
My code is to merge multiple sheet from a folder. I achieved the first requirement which merge all the sheet1 of target workbooks. But now, i want to merge the 4th sheet of the target workbooks. before that i need to check whether the sheet is exist or not. if exist the code should merge the 4th sheets. This one also i managed to achieved. However if the the 4th sheet not exist the code should do nothing. This part im still stuck. below are the code.
Set shtDest = ActiveWorkbook.Sheets("MS2")
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "PID2" Then
Wkb.Sheets(4).Activate
Set CopyRng = Wkb.Sheets(4).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
CopyRng.Copy Dest
Wkb.Close False
"ElseIf Worksheets(i).Name <> "PID2" Then"
"Wkb.Close False"
"Exit Sub"
End If
Next i
End If
Filename = Dir()
Loop
Assuming PID2 is the 4th sheet you want to copy, if it exists
Sub t()
Set shtDest = ActiveWorkbook.Sheets("MS2")
Filename = Dir(Path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=Path & "\" & Filename)
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "PID2" Then
Worksheets(i).Activate
Set CopyRng = Worksheets(i).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
CopyRng.Copy Dest
End If
Next i
Wkb.Close False
End If
Filename = Dir()
Loop
End Sub
PFA for the required code, I have made some modification in the code.
Set shtDest = ActiveWorkbook.Sheets("MS2")
Filename = Dir(Path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=Path & "\" & Filename)
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "PID2" Then
Wkb.Sheets(i).Activate
Set CopyRng = Range(Cells(RowofCopySheet, 1), ActiveCell.SpecialCells(xlCellTypeLastCell))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
CopyRng.Copy Dest
Exit For
End If
Next i
Wkb.Close False
End If
Filename = Dir()
Loop
You need to specify some criteria and then exit after that,
ie,
If something = <criteria> Then
goto exitsub
end if
exitsub:
This will jump to exitsub using the : at the end of the string you specify exitsub: You could make it anything you wanted, eg goToEndOfSub:
If something = <criteria> Then
goto goToEndOfSub
end if
goToEndOfSub:
Also you can use the Exit Statement, in your case a do loop.
Exit Do
I have used the following code to loop through the workbooks in a folder, each of which has multiple worksheets. In total I have 7 workbooks but I am able to copy only 3 workbooks to the summary sheet after that I am getting Run time error:1004 Method 'open' of object 'workbooks' failed. I am new to VBA and don't know how to resolve this issue. Can someone help me to debug this?
Public Sub ConsolidateSheets()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rngArea As Range
Dim lrowSpace As Long
Dim lSht As Long
Dim lngCalc As Long
Dim lngRow As Long
Dim lngCol As Long
Dim X()
Dim bProcessFolder As Boolean
Dim bNewSheet As Boolean
Dim StrPrefix
Dim strFileName As String
Dim strFolderName As String
Dim strDefaultFolder As Variant
bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
If Not bProcessFolder Then
If Not bNewSheet Then
MsgBox "There isn't much point creating a exact replica of your source file "
Exit Sub
End If
End If
strDefaultFolder = "D:\Tracker"
lrowSpace = 1
If bProcessFolder Then
strFolderName = BrowseForFolder(strDefaultFolder)
strFileName = Dir(strFolderName & "\*.xls*")
Else
strFileName = Application _
.GetOpenFilename("Select file to process (*.xls*), *.xls*")
End If
Set Wb1 = Workbooks.Add(1)
Set ws1 = Wb1.Sheets(1)
If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)
Do While Len(strFileName) > 0
Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
If Not bNewSheet Then
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
End If
For Each ws2 In Wb2.Sheets
If bNewSheet Then
Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)
If Not rng2 Is Nothing Then
Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
If Not rng1 Is Nothing Then
Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
If rng3.Rows.Count + rng1.Row < Rows.Count Then
ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
Else
MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
"sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
Wb2.Close False
Exit Do
End If
If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
Else
ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
End If
End If
Else
ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
With Wb1.Sheets(Wb1.Sheets.Count).Cells
.Copy
.PasteSpecial xlPasteValues
End With
On Error Resume Next
Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
If Err.Number <> 0 Then
Do
lSht = lSht + 1
Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
Loop While Not ws3 Is Nothing
lSht = 0
End If
On Error GoTo 0
End If
Next ws2
Wb2.Close False
If bProcessFolder = False Then Exit Do
strFileName = Dir
Loop
If bNewSheet Then
With ws1.UsedRange
.Copy
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).Activate
End With
Else
ws1.Activate
ws1.Range("A1:B1").Font.Bold = True
ws1.Columns.AutoFit
End If
With Application
.CutCopyMode = False
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculation = lngCalc
.StatusBar = vbNullString
End With
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function
I have a Workbook containing 30+ worksheets and each tab labeled " -A" or " -G".
I am trying to save the tab names ending with -A in a single workbook and -G in a different workbook.
I would like to move the worksheets to the new workbooks because I am using the first one as Master file. Also, sometimes there could be all -A and no -G and so on.
I am still working on the code below. I would appreciate any help! thanks!
Sub MoveSheets()
Dim ws As Worksheet, ss As Worksheet, FolderName As String, Wb1 As Workbook, Wb2 As Workbook
Application.ScreenUpdating = False
FolderName = ThisWorkbook.Path
DateString = Format(Now, "mm-dd-yy hh-mm")
For Each ws In ThisWorkbook.Worksheets
If Right(ws.Name, 3) = "-A" Then
ws.Move After:=ss
End If
Set ss = ActiveSheet
Next ws
ThisWorkbook.Activate
Wb.SaveAs FolderName _
& "\" & "AFILE" & " " & DateString
For Each ws In ThisWorkbook.Worksheets
If Right(ws.Name, 3) = "-G" Then
ws.Move After:=ss
End If
Set ss = ActiveSheet
Next ws
ThisWorkbook.Activate
Wb.SaveAs FolderName _
& "\" & "GFILE" & " " & DateString
Application.ScreenUpdating = True
End Sub
There you go, I know it can be made shorter and is kind of repetitive, but it should get the job done!
Let me know if this works for you.
UPDATED (Browse for folder added):
Sub MoveSheets()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & "\"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
fdlr = .SelectedItems(1)
End With
Dim oXLApp As Object, wb As Object, wb2 As Object, ws As Object
Dim TempFile1 As String, TempFile2 As String
Dim CountA As Long, CountG As Long
TempFile1 = Environ$("temp") & "/" & "1" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsm"
TempFile2 = Environ$("temp") & "/" & "2" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsm"
On Error Resume Next
Kill TempFile1
Kill TempFile2
On Error GoTo 0
ThisWorkbook.SaveCopyAs TempFile1
ThisWorkbook.SaveCopyAs TempFile2
'save AFILE
Set oXLApp = CreateObject("Excel.Application")
Set wb = oXLApp.Workbooks.Open(TempFile1)
oXLApp.DisplayAlerts = False
For Each ws In wb.Worksheets
ws.Visible = True
Next
CountA = 0
For Each ws In wb.Worksheets
If Right(ws.Name, 2) = "-A" Then CountA = CountA + 1
Next
If Not CountA = 0 Then
For Each ws In wb.Worksheets
If Not Right(ws.Name, 2) = "-A" Then ws.Delete
Next
'you can change the "FileFormat" in the below line to xlOpenXMLWorkbookMacroEnabled
'as well as change the extension to ".xlsm" in case you want to retain macro in your saved files
wb.SaveAs Filename:=fdlr & "\" & "AFILE" & " " & Format(Now, "mm-dd-yy hh-mm") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Set wb2 = oXLApp.ActiveWorkbook
wb2.Close (False)
End If
oXLApp.DisplayAlerts = True
On Error Resume Next
Kill TempFile1
On Error GoTo 0
oXLApp.Quit
Set oXLApp = Nothing
Set wb = Nothing
Set wb2 = Nothing
Set ws = Nothing
'save GFILE
Set oXLApp = CreateObject("Excel.Application")
Set wb = oXLApp.Workbooks.Open(TempFile2)
oXLApp.DisplayAlerts = False
For Each ws In wb.Worksheets
ws.Visible = True
Next
CountG = 0
For Each ws In wb.Worksheets
If Right(ws.Name, 2) = "-G" Then CountG = CountG + 1
Next
If Not CountG = 0 Then
For Each ws In wb.Worksheets
If Not Right(ws.Name, 2) = "-G" Then ws.Delete
Next
'you can change the "FileFormat" in the below line to xlOpenXMLWorkbookMacroEnabled
'as well as change the extension to ".xlsm" in case you want to retain macro in your saved files
wb.SaveAs Filename:=fdlr & "\" & "GFILE" & " " & Format(Now, "mm-dd-yy hh-mm") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Set wb2 = oXLApp.ActiveWorkbook
wb2.Close (False)
End If
oXLApp.DisplayAlerts = True
On Error Resume Next
Kill TempFile2
On Error GoTo 0
oXLApp.Quit
Set oXLApp = Nothing
Set wb = Nothing
Set wb2 = Nothing
Set ws = Nothing
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If Right(ws.Name, 2) = "-A" Or Right(ws.Name, 2) = "-G" Then ws.Delete
Next
Application.DisplayAlerts = True
End Sub