I am aiming to split out all the worksheets of my workbook, save them as individual files and then, to each new workbook, add a Guidance worksheet (guidance worksheet is the same for all workbooks). The part of the code works perfectly, filling empty xPath directory with a new workbook for each tab.
The code then completely skips the Do While loop section for no reason. If you comment out the For Each loop, then it works. I have no idea why.
Sub SplitWorkbooktoFile()
Dim xPath As String
Dim wb As Workbook
Dim file As String
Set wb = ActiveWorkbook
xPath = "C:\Users\AH Test\"
file = Dir(xPath)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In wb.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Do While Not file = ""
Workbooks.Open (xPath & file)
Set wb = ActiveWorkbook
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "User Guidance"
ThisWorkbook.Sheets("Guidance").Range("A1:C8").Copy
wb.Sheets("User Guidance").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb.Sheets("User Guidance").Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb.Sheets("User Guidance").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb.Save
wb.Close
file = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Thank you to #Nathan_Sav for prompting me to the correct answer. Just needed to put the file = dir(xpath) after the for each loop.
Sub SplitWorkbooktoFile()
Dim xPath As String
Dim wb As Workbook
Dim file As String
Set wb = ActiveWorkbook
xPath = "C:\Users\AH Test\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In wb.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
file = Dir(xPath)
Do While Not file = ""
Workbooks.Open (xPath & file)
Set wb = ActiveWorkbook
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "User Guidance"
ThisWorkbook.Sheets("Guidance").Range("A1:C8").Copy
wb.Sheets("User Guidance").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb.Sheets("User Guidance").Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb.Sheets("User Guidance").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wb.Save
wb.Close
file = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Related
I have been searching for the answer to this question and have found some helpful hints but can't make it work within this code.
I'm copying three tabs and the workbook's name is in Cover!R11 but the other two tabs from that file need the filename as well with an extension (i.e. Filename, Cover, Filename Summary, Filename Estimate). If I reference the cell with the filename when I'm on the second sheet, how can I reference the previous sheet? That's why I thought it easier to use the Filename instead. I tried using: Sheets(SheetName1).Name = FilePath but I can't figure out how to trim it within this code. Can you help?
Here's the code:
Sub CopySheets()
Dim DialogBox As FileDialog
Dim FilePath As String
Dim SheetName As String
Set DialogBox = Application.FileDialog(msoFileDialogFilePicker)
DialogBox.Title = "Select Estimates to copy " & FileType
DialogBox.AllowMultiSelect = True
DialogBox.Filters.Clear
DialogBox.Show
If DialogBox.SelectedItems.Count = 1 Then
FilePath = DialogBox.SelectedItems(1)
End If
For i = 1 To DialogBox.SelectedItems.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = DialogBox.SelectedItems(i)
SheetName1 = "Cover"
SheetName2 = "Summary"
SheetName3 = "Estimate and Schedule "
Set closedBook = Workbooks.Open(FilePath)
closedBook.Sheets(SheetName1).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B2:Z97").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'The file name I want to use is in this field, but I can't reference it for the other tabs.
Sheets(SheetName1).Name = Range("R11")
closedBook.Sheets(SheetName2).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B5:K39").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'This line here didn't work to pull the previous sheet's value in R11
'Sheets(SheetName2).Name = prevname.Range("R11") & "Summary"
closedBook.Sheets(SheetName3).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("A3:M70").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
closedBook.Close SaveChanges:=False
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
If you want to use the value from 'Cover'!R11 later in the code store it in a variable.
'The file name I want to use is in this field, but I can't reference it for the other tabs.
Dim strFilename As String
' other code
strFilename = Sheets("Cover").Range("R11").Value
Sheets(SheetName1).Name = strFilename
' more code
Sheets(SheetName2).Name = strFilename & " Summary"
' even more code
Sheets(SheetName2).Name = strFilename & " Estimate"
Just wondering if anyone can help me clean up my code. It currently works perfectly for what I need it to do. Just wondering if it can run faster. Right now it seems to open and close each workbook 3 times before moving to the next one.
Sub JanuaryMacro()
Dim strF As String, strP As String
Dim wb As Workbook
Range("B2:M2").clearcontents
'Edit this declaration to your folder name
strP = "\\My path" 'change for the path of your folder
strF = Dir(strP & "\*.xlsx")
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Do While strF <> vbNullString
Set wb = Workbooks.Open(strP & "\" & strF)
Range("Totals").Select
Selection.Copy
Windows("Monthly Report.xlsm").Activate
Range("D2:M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
Set wb = Workbooks.Open(strP & "\" & strF)
Range("FG_Approvals").Select
Selection.Copy
Windows("Monthly Report.xlsm").Activate
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
Set wb = Workbooks.Open(strP & "\" & strF)
Range("Allocations").Select
Selection.Copy
Windows("Monthly Report.xlsm").Activate
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
wb.Close SaveChanges:=False
strF = Dir()
Loop
Application.DisplayAlerts = True
End Sub
You should use references to your monthly-report-sheet, the new workbook and its sheet e. g. like this:
Sub JanuaryMacroVersion2()
Dim strF As String, strP As String
Dim mr As Worksheet
Dim wb As Workbook, ws As Worksheet
Set mr = ActiveSheet ' your monthly report
mr.Range("B2:M2").ClearContents
strP = "\\My path" 'change for the path of your folder
strF = Dir(strP & "\*.xlsx")
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Do While strF <> vbNullString
Set wb = Workbooks.Open(strP & "\" & strF)
Set ws = ActiveSheet
ws.Range("Totals").Copy
mr.Range("D2:M2").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlAdd, _
SkipBlanks:=False, Transpose:=False
ws.Range("FG_Approvals").Copy
mr.Range("C2").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlAdd, _
SkipBlanks:=False, Transpose:=False
ws.Range("Allocations").Copy
mr.Range("B2").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlAdd, _
SkipBlanks:=False, Transpose:=False
wb.Close SaveChanges:=False
strF = Dir()
Loop
Application.DisplayAlerts = True
End Sub
If the range names like "FG_Approvals" refer to a workbook wide name, replace ws.Range("FG_Approvals")by wb.Range("FG_Approvals").
Next optimization step would be omitting copy/paste by assigning their Range.Value directly:
Sub JanuaryMacroVersion3()
Dim strF As String, strP As String
Dim mr As Worksheet
Dim wb As Workbook, ws As Worksheet
Dim lastRow As Long
Set mr = ActiveSheet
mr.Range("B2:M2").ClearContents
strP = "\\My path" 'change for the path of your folder
strF = Dir(strP & "\*.xlsx")
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Do While strF <> vbNullString
Set wb = Workbooks.Open(strP & "\" & strF)
Set ws = ActiveSheet
lastRow = mr.Cells(mr.Rows.Count, "D").End(xlUp).Row
mr.Cells(lastRow + 1, "D").Resize _
(ws.Range("Totals").Rows.Count, _
ws.Range("Totals").Columns.Count).Value _
= ws.Range("Totals").Value
lastRow = mr.Cells(mr.Rows.Count, "C").End(xlUp).Row
mr.Cells(lastRow + 1, "C").Resize _
(ws.Range("FG_Approvals").Rows.Count, _
ws.Range("FG_Approvals").Columns.Count).Value _
= ws.Range("FG_Approvals").Value
lastRow = mr.Cells(mr.Rows.Count, "B").End(xlUp).Row
mr.Cells(lastRow + 1, "B").Resize _
(ws.Range("Allocations").Rows.Count, _
ws.Range("Allocations").Columns.Count).Value _
= ws.Range("Allocations").Value
wb.Close SaveChanges:=False
strF = Dir()
Loop
Application.DisplayAlerts = True
End Sub
I'm trying to write a macro that will Open files one by one in a provided directory, calculate all formulas, paste values over specific formulas, save, and exit, repeat process with next file. Here's what i have below:
Sub LoopPaloSnapshot()
Dim wb As Workbook
Dim ws As Worksheet
Dim MyPath As String
Dim FldrPicker As FileDialog
Dim FSO As New FileSystemObject
Dim MyFolder As Folder
Dim SubFolder As Folder
Dim MyFile2 As File
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
Set FSO = CreateObject("scripting.filesystemobject")
'In Case of Cancel
NextCode:
MyPath = MyPath
Set MyFolder = FSO.GetFolder(MyPath)
For Each SubFolder In MyFolder.SubFolders
For Each MyFile2 In SubFolder.Files
If FSO.GetExtensionName(MyFile2.Path) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=MyFile2, UpdateLinks:=0)
Set ws = wb.Worksheets("Staffing Model")
Application.Run ("PALO.CALCSHEET")
Application.Calculate
Application.Run ("PALO.CALCSHEET")
Application.Calculate
Application.Calculation = xlCalculationManual
ws.Range("B1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F10:Q10").Value = ws.Range("F10:Q10").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F20:Q22").Value = ws.Range("F20:Q22").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F42:Q43").Value = ws.Range("F42:Q43").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F56:Q56").Value = ws.Range("F56:Q56").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F61:Q61").Value = ws.Range("F61:Q61").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F66:Q66").Value = ws.Range("F66:Q66").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
'Break Links
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
Dim xWs As Worksheet
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Staffing Model" Then
xWs.Delete
End If
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Loop
End If
Next
Next
MsgBox "Task Complete!"
ResetSettings:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
After running this, i open the newly saved files and there are #Value errors in place of the formulas im attempting to calculate and paste values over. I've tried walking through the macro line by line and it seems to be working properly for the most part, but for some reason the formulas are not calculating. if i open the file manually prior to running the macro, everything calculates perfectly so im wondering if something is causing these formulas to not calculate while the macro is running. any help would be appreciated.
EDIT: the formulas im copying and pasting values over are HLOOKUP's pulling from other tabs within the workbook, and PALO formulas pulling data directly from a JEDOX server. i've manually ran through the process im trying to automate without errors.
Instead of copying and pasting complex formulas, I'd suggest writing the formulas directly into the cells using this method:
Worksheets("Sheet1").Range("A1").Formula = "=$A$4+$A$10"
Pasted formulas can sometimes carry references to the original worksheet which causes chaos, whereas an explicitly set formula will not do that.
If you're really trying to take it offline then you could also use this method to set values as well.
Worksheets("Sheet1").Range("A1").Value = "100"
Firstly I am a newbie when it comes to coding, but am giving it a go to see how it can help me dig down into my data.
I am currently looking at capturing time-sheet data for different team members and copying it into a master summary workbook.
I recorded my macro and then re-organised things a bit to make the code cleaner (this may be where I went wrong). But now when I run my macro I get a Run-time error '9': Subscript out of range.
my code is as follows:
Option Explicit
Sub MergeAll()
' Open all Timesheets
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_JAMAL.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_LOKESH.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_NONI.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_RAJESH.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_SANTHOSH.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_7.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_8.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_9.xlsx"
' Activate and Copy Data
Windows("2016_JAMAL.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_LOKESH.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_NONI.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_RAJESH.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_SANTHOSH.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_WARREN.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_7.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_8.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
Windows("2016_9.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2:F2").Select
ActiveSheet.Paste
' Close all Timesheets
Windows("2016_JAMAL.xlsx").Activate
ActiveWindow.Close
Windows("2016_LOKESH.xlsx").Activate
ActiveWindow.Close
Windows("2016_NONI.xlsx").Activate
ActiveWindow.Close
Windows("2016_RAJESH.xlsx").Activate
ActiveWindow.Close
Windows("2016_SANTHOSH.xlsx").Activate
ActiveWindow.Close
Windows("2016_WARREN.xlsx").Activate
ActiveWindow.Close
Windows("2016_7.xlsx").Activate
ActiveWindow.Close
Windows("2016_8.xlsx").Activate
ActiveWindow.Close
Windows("2016_9.xlsx").Activate
ActiveWindow.Close
End Sub
Now I took out some code which was appearing in each line, after the Windows("filename").Activate line. This was:
ActiveWindow.SmallScroll Down:=-18
As I believe that this was only when I scrolled up to the correct place and depending on which was the active cell prior to saving each time, this would change.
I am out of ideas and any help would be much appreciated.
For the record, I have so far tried several different methods - including copying and pasting code from sites, following you tube tutorial videos, but each time and each method, the same error occurs.
Thanks in advance,
Rich
UPDATE
I re-recorded the macro and simply changed the order of what I did during the record. I no longer get the error. However the code is very messy and long winded. The screen flickers a lot during the process too. is there a way to make it a smoother experience for the user? The new code is below
Sub MergeAll2()
'
' MergeAll2 Macro
'
'
' Open All
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_7.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_8.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_9.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_JAMAL.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_LOKESH.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_NONI.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_RAJESH.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_SANTHOSH.xlsx"
Workbooks.Open Filename:= _
"S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\2016_WARREN.xlsx"
' Copy & Paste
Windows("2016_JAMAL.xlsx").Activate
Range("G2:J2").Select
Selection.Copy
Windows("master.xlsm").Activate
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_LOKESH.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C3:F3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_NONI.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_RAJESH.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_SANTHOSH.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_WARREN.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_7.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_8.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("2016_9.xlsx").Activate
Range("G2:J2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("master.xlsm").Activate
Range("C10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Close All
Windows("2016_JAMAL.xlsx").Activate
ActiveWindow.Close
Windows("2016_LOKESH.xlsx").Activate
ActiveWindow.Close
Windows("2016_NONI.xlsx").Activate
ActiveWindow.Close
Windows("2016_RAJESH.xlsx").Activate
ActiveWindow.Close
Windows("2016_SANTHOSH.xlsx").Activate
ActiveWindow.Close
Windows("2016_WARREN.xlsx").Activate
ActiveWindow.Close
Windows("2016_7.xlsx").Activate
ActiveWindow.Close
Windows("2016_8.xlsx").Activate
ActiveWindow.Close
Windows("2016_9.xlsx").Activate
ActiveWindow.Close
End Sub
UPDATE 2
Many thanks for the help so far. I am looking to edit this line:
Workbooks("master").ActiveSheet.Range("C2:F2").Value = Workbooks("2016_JAMAL").ActiveSheet.Range("G2:J2").Value
So that I can choose which sheet in "master" to write it to and also which sheet in "2016_JAMAL" to copy it from.
Secondly, I want to copy from two ranges on this sheet - C2:G2 and C5:G56
I would like to do this in a streamlined way.
Many thanks for your answers so far - I will read the information on Arrays and work through the 5 pages!
Rich
You can stop the flickering screen by setting the following:
Application.ScreenUpdating = False
Add that to your macro and run it again.
You should be able to speed up your "Copy & Paste" section by using this instead:
With Workbooks("master").ActiveSheet
.Range("C2:F2").Value = Workbooks("2016_JAMAL").ActiveSheet.Range("G2:J2").Value
.Range("C3:F3").Value = Workbooks("2016_LOKESH").ActiveSheet.Range("G2:J2").Value
.Range("C4:F4").Value = Workbooks("2016_NONI").ActiveSheet.Range("G2:J2").Value
.Range("C5:F5").Value = Workbooks("2016_RAJESH").ActiveSheet.Range("G2:J2").Value
.Range("C6:F6").Value = Workbooks("2016_SANTHOSH").ActiveSheet.Range("G2:J2").Value
.Range("C7:F7").Value = Workbooks("2016_WARREN").ActiveSheet.Range("G2:J2").Value
.Range("C8:F8").Value = Workbooks("2016_7").ActiveSheet.Range("G2:J2").Value
.Range("C9:F9").Value = Workbooks("2016_8").ActiveSheet.Range("G2:J2").Value
.Range("C10:F10").Value = Workbooks("2016_9").ActiveSheet.Range("G2:J2").Value
End With
You could also make your "close" part simpler by using:
Workbooks("2016_JAMAL.xlsx").Close False
Workbooks("2016_LOKESH.xlsx").Close False
Workbooks("2016_NONI.xlsx").Close False
Workbooks("2016_RAJESH.xlsx").Close False
Workbooks("2016_SANTHOSH.xlsx").Close False
Workbooks("2016_WARREN.xlsx").Close False
Workbooks("2016_7.xlsx").Close False
Workbooks("2016_8.xlsx").Close False
Workbooks("2016_9.xlsx").Close False
I used Activesheet not knowing how many sheets each workbook has or their names. You can adjust accordingly. Here's my version:
Option Explicit
Sub MergeAll2()
Dim wb2016_7 As Workbook
Dim wb2016_8 As Workbook
Dim wb2016_9 As Workbook
Dim wb2016_JAMAL As Workbook
Dim wb2016_LOKESH As Workbook
Dim wb2016_NONI As Workbook
Dim wb2016_RAJESH As Workbook
Dim wb2016_SANTHOSH As Workbook
Dim wb2016_WARREN As Workbook
Dim strPath As String
Application.ScreenUpdating = False
strPath = "S:\UFD\24 Reports\02 Time Keeping\PT Time Sheets\"
Set wb2016_7 = Workbooks.Open(Filename:=strPath & "2016_7.xlsx")
Set wb2016_8 = Workbooks.Open(Filename:=strPath & "2016_8.xlsx")
Set wb2016_9 = Workbooks.Open(Filename:=strPath & "2016_9.xlsx")
Set wb2016_JAMAL = Workbooks.Open(Filename:=strPath & "2016_JAMAL.xlsx")
Set wb2016_LOKESH = Workbooks.Open(Filename:=strPath & "2016_LOKESH.xlsx")
Set wb2016_NONI = Workbooks.Open(Filename:=strPath & "2016_NONI.xlsx")
Set wb2016_RAJESH = Workbooks.Open(Filename:=strPath & "2016_RAJESH.xlsx")
Set wb2016_SANTHOSH = Workbooks.Open(Filename:=strPath & "2016_SANTHOSH.xlsx")
Set wb2016_WARREN = Workbooks.Open(Filename:=strPath & "2016_WARREN.xlsx")
With Workbooks("master").ActiveSheet
.Range("C2:F2").Value = wb2016_JAMAL.ActiveSheet.Range("G2:J2").Value
.Range("C3:F3").Value = wb2016_LOKESH.ActiveSheet.Range("G2:J2").Value
.Range("C4:F4").Value = wb2016_NONI.ActiveSheet.Range("G2:J2").Value
.Range("C5:F5").Value = wb2016_RAJESH.ActiveSheet.Range("G2:J2").Value
.Range("C6:F6").Value = wb2016_SANTHOSH.ActiveSheet.Range("G2:J2").Value
.Range("C7:F7").Value = wb2016_WARREN.ActiveSheet.Range("G2:J2").Value
.Range("C8:F8").Value = wb2016_7.ActiveSheet.Range("G2:J2").Value
.Range("C9:F9").Value = wb2016_8.ActiveSheet.Range("G2:J2").Value
.Range("C10:F10").Value = wb2016_9.ActiveSheet.Range("G2:J2").Value
End With
wb2016_7.Close True
wb2016_8.Close True
wb2016_9.Close True
wb2016_JAMAL.Close True
wb2016_LOKESH.Close True
wb2016_NONI.Close True
wb2016_RAJESH.Close True
wb2016_SANTHOSH.Close True
wb2016_WARREN.Close True
Set wb2016_7 = Nothing
Set wb2016_8 = Nothing
Set wb2016_9 = Nothing
Set wb2016_JAMAL = Nothing
Set wb2016_LOKESH = Nothing
Set wb2016_NONI = Nothing
Set wb2016_RAJESH = Nothing
Set wb2016_SANTHOSH = Nothing
Set wb2016_WARREN = Nothing
Application.ScreenUpdating = True
End Sub
It's good practice to use Option Explicit which forces you to declare your variables and to set your objects back to Nothing after using them.
EDIT
I would replace Activesheet with Sheets("SheetName") for each of the workbooks. Otherwise you could put the following code in the workbook object for every workbook (and save them all as macro enabled), except master, and keep Activesheet:
Private Sub Workbook_Open( )
Sheets ("SheetName").Activate
End Sub
I would, at least, change Workbooks("master").ActiveSheet to Workbooks("master").Sheets("SheetName") or you'll need to remember to run it from the correct (that is, active) sheet. This is a very helpful link, also.
This will merge a range from all workbooks in a folder (next data set goes below prior).
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
This will merge a range from all workbooks in a folder (next data set goes to the right of prior).
Sub Basic_Example_3()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceCcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim Cnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
Cnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
Set sourceRange = mybook.Worksheets(1).Range("A1:A10")
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all rows then skip this file
If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceCcount = sourceRange.Columns.Count
If Cnum + SourceCcount >= BaseWks.Columns.Count Then
MsgBox "Sorry there are not enough columns in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in the first row
With sourceRange
BaseWks.cells(1, Cnum). _
Resize(, .Columns.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.cells(2, Cnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Cnum = Cnum + SourceCcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
I have a workbook which performs several Excel-functions that depend on one variable and fills out itself. I have a loop to create those forms and save in a directory but before that I want to copy all and paste special so that formulas will be gone.
Sub SaveAs1()
For i = 172 To 225
Dim SaveName As Integer
SaveName = ActiveWorkbook.Sheets(1).Range("bi1").value
Application.ActiveWorkbook.SaveAs "C:\" & SaveName
Range("bi1") = i + 1
Next
End Sub
I figure that out finally using trial and error method
Sub Save()
Rem kaydetmece dongusu
For i = 172 To 180 Step 1
Application.DisplayAlerts = False
Workbooks.Open Filename:="C:\"
Range("bi1") = i + 1
Dim SaveName As Integer
SaveName = ActiveWorkbook.Sheets(1).Range("bi1").value
Range("A1:BE63").Select
Range("a1").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ActiveWorkbook.SaveAs "C:\" & SaveName
Columns("BE:BU").Select
Selection.Delete Shift:=xlToLeft
Sheets("CAL").Select
ActiveWindow.SelectedSheets.Delete
Sheets("sahadan").Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Close True
Next
End Sub
If you're asking how to paste values, this is how you do it. Replace "A1" with the actual range you need to use.
Range("A1").Copy
Range("A1").PasteSpecial xlPasteValues