Here's my struggle.. I found this macro, which I'm trying to modify so I only get select worksheet copied (in my case, I want the sheet called "Indexable"). I'm clueless how to get that... please help
Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wks As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wks In wbkSrcBook.Sheets
countSheets = countSheets + 1
wks.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
Related
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
I pulled this code online, I am a noob, but I have made some changes to the looping. Please help me out! I want to get this macro working on other sheets, saved to the macro ribbon. I've added it as an Add-In, checked security settings, checked tools>references. The problem is if I save it as a module under the excel file I want to split, it works, but if I save it in a blank sheet and pull it as a macro, which is my goal for my team to use, the macro pulls the blank original sheet and breaks the master in half; leaving the active sheet untouched.
Sub Macrosplittest()
Dim Sht As Worksheet
Dim fName As String
Dim ShtCountBk1 As Integer
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ShtCountBk1 = IIf(ActiveWorkbook.Sheets.Count Mod 2 = 1, Sheets.Count
/ 2 + 0.5, Sheets.Count / 2)
Set neww = Workbooks.Add
For Each Sht In ActiveWorkbook.Worksheets
i = i + 1
If i > ShtCountBk1 Then
fName = Replace(ThisWorkbook.Name, ".xls", "")
neww.SaveAs ThisWorkbook.Path & "\" & fName & " (1).xls"
Set neww = Workbooks.Add
i = 1
End If
Sht.Copy after:=Worksheets(neww.Sheets.Count)
If i = 1 Then
For Each ws In Worksheets
If ws.Name <> Sht.Name Then
ws.Delete
End If
Next ws
End If
Next Sht
fName = Replace(ThisWorkbook.Name, ".xls", "")
neww.SaveAs ThisWorkbook.Path & "\" & fName & " (2).xls"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Try this, I think I see what you are trying to do:
Sub Macrosplittest()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sht As Worksheet
Dim fName As String
Dim ShtCountBk1 As Integer
Dim ws As Worksheet
Dim wbActive as Workbook
Dim newBook as Workbook
Dim lHolder as Long
Dim sHolder as String
Dim i as Long
Set wbActive = ActiveWorkbook
lHolder = wbActive.Sheets.Count
If lHolder Mod 2 = 1 Then
' This should evaluate just fine without parentheses, but I
' prefer to have the parentheses to make the code clear
ShtCountBk1 = (lHolder / 2) + .05
Else
ShtCountBk1 = lHolder / 2
End IF
Set newBook = Workbooks.Add
For Each Sht In wbActive.Worksheets
i = i + 1
Sht.Name = "SHT-" & Sht.Name
sHolder = Sht.Name
If i > ShtCountBk1 Then
fName = Replace(wbActive.Name, ".xls", "")
newBook.SaveAs wbActive.Path & "\" & fName & " (1).xls"
Set newBook= Workbooks.Add
i = 1
End If
Sht.Copy after:=Worksheets(newBook.Sheets.Count)
If i = 1 Then
For Each ws In Worksheets
If ws.Name <> sHolder Then
ws.Delete
End If
Next ws
End If
Next Sht
fName = Replace(wbActive.Name, ".xls", "")
newBook.SaveAs wbActive.Path & "\" & fName & " (2).xls"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have made some modifications to make your code easier to read, and to make it properly refer to the workbooks you are targeting. It is best to avoid ActiveWorkbook since this can result in errors. Also, ThisWorkbook will refer to the workbook running the code. I am not sure if this will properly refer to the activeworkbook when ThisWorkbook is called by a add-in, but it is best to err on the side of caution.
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
I have multiple workbooks in the same layout. In the cell "I8" I have calculated a specific value that I want to compile from all workbooks.
Here is an example of my code:
Sub Code()
Dim file As String
Dim wbResults As Workbook
Dim myPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
myPath = "C:\Test\"
file = Dir$(myPath & "*.xls*")
While (Len(file) > 0)
Set wbResults = Workbooks.Open(Filename:=myPath & file, UpdateLinks:=0)
With wbResults.Worksheets(Split(file, ".")(0))
With .Range("I8")
.Formula = "=10^(D28+(I7*I2))"
End With
End With
wbResults.Close SaveChanges:=True
file = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I would like to add to this code and compile a list in another excel workbook where column A puts the name of the file of a workbook and column B puts the value of "I8" in that respective workbook.
Here is my answer:
Sub Code()
Dim file As String
Dim wbResults As Workbook
Dim myPath As String
myPath = "C:\Test\"
'---------------- Create a new workbook then save it ----------------
Dim WBSummary As Workbook
Set WBSummary = Excel.Application.Workbooks.Add
WBSummary.SaveAs myPath & "WBSummary.xls"
'--------------------------------------------------------------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
file = Dir$(myPath & "*.xls*")
Dim i As Long 'To update row number in WBSummary
While (Len(file) > 0)
i = i + 1
If file <> "WBSummary.xls" Then
Set wbResults = Workbooks.Open(Filename:=myPath & file, UpdateLinks:=0)
With wbResults.Worksheets(Split(file, ".")(0))
With .Range("I8")
.Formula = "=10^(D28+(I7*I2))"
.Calculate 'To update value in "I8"
WBSummary.Worksheets(1).Cells(i, 1).Value = file
WBSummary.Worksheets(1).Cells(i, 2).Value = .Value
End With
End With
wbResults.Close SaveChanges:=True
End If
file = Dir
Wend
WBSummary.Close True 'Close and Save WBSummary
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Problem I have is, when I am saving my my worksheet as another workbook using code below I also need to copy additional worksheet only on one occasion when formulas on the worksheet I intend to save refer to the "Price List" worksheet, which I would need to also save along with the first worksheet. I hope it make sense. Also another small problem, when I save worksheet as a new workbook, I need that workbook to open imedietly, so that I can then continue to work with that workbook.
Here is my code
Private Sub UserForm_Initialize()
Dim ws As Worksheet
For Each ws In Worksheets
If InStr(LCase(ws.Name), "template") <> 0 Then
cmbSheet.AddItem ws.Name
End If
Next ws
End Sub
'Continue to create your invoice and check for the archive folder existance
Private Sub ContinueButton_Click()
If cmbSheet.Value = "" Then
MsgBox "Please select the Invoice Template from the list to continue."
ElseIf cmbSheet.Value <> 0 Then
Dim response
Application.ScreenUpdating = 0
'Creating the directory only if it doesn't exist
directoryPath = getDirectoryPath
If Dir(directoryPath, vbDirectory) = "" Then
response = MsgBox("The directory " & Settings.Range("_archiveDir").Value & " does not exist. Would you like to create it?", vbYesNo)
If response = vbYes Then
createDirectory directoryPath
MsgBox "The folder has been created. " & directoryPath
Application.ScreenUpdating = False
Else
MsgBox "You need to create new folder " & Settings.Range("_archiveDir").Value & " to archive your invoices prior to creating them."
GoTo THE_END
End If
End If
If Dir(directoryPath, vbDirectory) <> directoryPath Then
Sheets(cmbSheet.Value).Visible = True
'Working in Excel 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim fName As String
Dim sep As String
sep = Application.PathSeparator
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Copy the sheet to a new workbook
Sourcewb.Sheets(cmbSheet.Value).Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
GoTo THE_END
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 56
End Select
End If
End If
End With
'Copy current colorscheme to the new Workbook
For i = 1 To 56
Destwb.Colors(i) = Sourcewb.Colors(i)
Next i
'If you want to change all cells in the worksheet to values, uncomment these lines.
'With Destwb.Sheets(1).UsedRange
'With Sourcewb.Sheets(cmbSheet.Value).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
'End With
Application.CutCopyMode = False
'Save the new workbook and close it
Destwb.Sheets(1).Name = "Invoice"
fName = Home.Range("_newInvoice").Value
TempFilePath = directoryPath & sep
TempFileName = fName
With Destwb
.SaveAs TempFilePath & TempFileName, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
MsgBox "You can find the new file in " & TempFilePath & TempFileName
End If
End If
THE_END:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Unload Me
End Sub
If I'm understanding you correctly, based on what you said you need to do two things:
Copy a worksheet when formulas contain references to the "Price List" worksheet
Save the new worksheet as a new workbook and open immediately
Here is code to paste in a module:
Sub IdentifyFormulaCellsAndCopy()
'******** Find all cells that contain formulas and highlight any that refer to worksheet 'price list' **********
Dim ws As Worksheet
Dim rng As Range
Set ws = ActiveSheet
For Each rng In ws.Cells.SpecialCells(xlCellTypeFormulas)
If InStr(LCase(rng.Formula), "price list") <> 0 Then
'Highlight cell if it contains formula
rng.Interior.ColorIndex = 36
End If
Next rng
'*******************************************************************************************************************
'********* Save worksheet as new workbook, then activate and open immediately to begin work on it *******************
'Hide alerts
Application.DisplayAlerts = False
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
FPath = "C:\Users\User\Desktop"
FName = "CopiedWorksheet " & Format(Date, "yyyy-mm-dd") & ".xls"
'Create a new workbook
Set NewBook = Workbooks.Add
'Copy the 'template' worksheet into new workbook
ThisWorkbook.Sheets("template").Copy Before:=NewBook.Sheets(1)
'If file doesn't already exist, then save new workbook
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName
End If
'Activate workbook that you just saved
NewBook.Activate
'Show Alerts
Application.DisplayAlerts = True
'**********************************************************************************************************************
End Sub
Notes:
Depending on how you implement this code, you can add Application.ScreenUpdating = False to speed things up.
Also, this code assumes that you have worksheets with the names of template and Price List.