Macro to copy data from one workbook to another - vba

I'm struggling with a macro that I'm trying to create that will pull data into a Master workbook from a different workbook that is updated weekly.
The problem I'm having is that the file I receive weekly is always named differently (updated for the week ending) and 7 of the 8 tabs in the workbook are also named differently (one for each day of the week that applies in that week ending range).
If it was a static file name, the macro is a piece of cake and works perfectly. I've read a great deal on a number of forums about how you can set it the macro to look at an ACTIVE workbook, rather than a specifically named one, but I just can't seem to get that to work.
Below is my macro for the specifically name file; what do I need to do differently so that I can run it on the file I receive each week just by having it open and active?
Sub SecData()
'
' SecData Macro
' Macro to move security badge-in data from weekly file to Master Security Log workbook. Will overwrite Sheet1
'
'
Sheets("Sheet1").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Range("A2").Select
Windows("Framingham counts for the week ending 06-02-18.xlsx").Activate
Sheets("05-27").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Selection.Copy
Windows("Master Security Logs.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A13").Select
Windows("Framingham counts for the week ending 06-02-18.xlsx").Activate
Sheets("05-28").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Master Security Logs.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=18
Range("A32").Select
Windows("Framingham counts for the week ending 06-02-18.xlsx").Activate
Sheets("05-29").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlUp)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Master Security Logs.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D32").Select
Selection.End(xlDown).Select
ActiveWindow.SmallScroll Down:=18
Range("A2154").Select
Windows("Framingham counts for the week ending 06-02-18.xlsx").Activate
Sheets("05-30").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Master Security Logs.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D2154").Select
Selection.End(xlDown).Select
ActiveWindow.SmallScroll Down:=9
Range("A4378").Select
Windows("Framingham counts for the week ending 06-02-18.xlsx").Activate
Sheets("05-31").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Master Security Logs.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D4378").Select
Selection.End(xlDown).Select
ActiveWindow.SmallScroll Down:=12
Range("A6638").Select
Windows("Framingham counts for the week ending 06-02-18.xlsx").Activate
Sheets("06-01").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Master Security Logs.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D6638").Select
Selection.End(xlDown).Select
ActiveWindow.SmallScroll Down:=18
Range("A8435").Select
Windows("Framingham counts for the week ending 06-02-18.xlsx").Activate
Sheets("06-02").Select
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Master Security Logs.xlsx").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ScrollRow = 7397
ActiveWindow.ScrollRow = 2466
ActiveWindow.ScrollRow = 1
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

#Lacey LaDue, I can't really make good sense of the copy and paste ranges but I know what you are doing, defining the range of the copy sheet, selected a cell in your master sheet and pasting it in.
365 tabs? I thought you were doing this weekly?
You could always copy tab (worksheets) themselves but it looks like you are putting a weeks data on a single master sheet page.
Here is the frame work in one sub (macro) but I did not perform the copy and paste for each worksheet into your master worksheet / workbook, but this gets you close as it shows you how to get the file, open the file, and then walk through the worksheets 1 at a time and perform tasks on them.
I would need to know more about the copysheet and the master sheet to do the detail work. I hop this helps you out. I am guessing your macro code is from the macro recorder because of all of the selects.
Option Explicit
'Sub to get the Current urFileName
Private Sub getFN()
Dim Finfo As String
Dim FilterIndex As Long
Dim Title As String
Dim CopyBook As Workbook 'Workbook to copy from
Dim CopySheet As Worksheet 'Worksheet to copy from
Dim FN As Variant 'File Name
Dim wsNum As Double 'worksheet # as you move through the Copy Book
Dim cwsLastRow As Long 'copy worksheet last row
Dim mwsLastRow As Long 'master worksheet last row
Dim masterWS As Worksheet 'thisworkbook, your master worksheet
Set masterWS = ThisWorkbook.Worksheets("Master Security Logs")
'Set up file filter
Finfo = "Excel Files (*.xls*),*.xls*"
'Set filter index to Excel Files by default in case more are added
FilterIndex = 1
' set Caption for dialogue box
Title = "Select the Current AP Reconcile Workbook"
'get the Forecast Filename
FN = Application.GetOpenFilename(Finfo, FilterIndex, Title)
'Handle file Selection
If FN = False Then
MsgBox "No file was selected.", vbExclamation, "Not so fast"
Else
'Do your Macro tasks here
'Supress Screen Updating but don't so this until you know your code runs well
Application.ScreenUpdating = False
'Open the AP File
Workbooks.Open (FN)
'Hide the file so it is out of the way
Set CopyBook = ActiveWorkbook
For wsNum = 1 To CopyBook.Sheets.Count 'you stated there will be 8, this is safer
'Do your work here, looks like you are copying certain ranges from wach sheet into ThisWorkbook
CopySheet = CopyBook.Worksheets(wsNum) '1,2,3,4,5,6,7,8
'Finds the lastRow in your Copysheet each time through
cwsLastRow = CopySheet.Cells(CopySheet.Rows.Count, "A").End(xlUp).Row
'so you would have to keep tabs on what the lastRow of this sheet is too and always start at +1
mwsLastRow = masterWS.Cells(masterWS.Rows.Count, "A").End(xlUp).Row
'Do some copy and pasting between copySheet and masterWS based on your ranges
'It looks like you copy data from each ws into your single master book worksheet
'Clear the clipboard before you go around again
Application.CutCopyMode = False
Next wsNum
End If
'Close the workbook opened for the copy
CopyBook.Close savechanges:=False 'Not needed now
'Screen Updating Back on
Application.ScreenUpdating = True
End Sub

Related

How do i combine macro module with the rest of the code

I'm a beginner, so any help is much appreciated, I want to combine this macro with the first code, but I don't know how to do that or where to put it.
this is the first code (it has a mistake in it, but I already have an answer on how to fix it, so it's alright):
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("inbd")
Dim wsDestination As Worksheet: Set wsDestination = Sheets("test")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1, Criteria1:=Worksheets("test").Cells(1, 26).Value
ws.Range("f2:f" & LastRow).SpecialCells(xlCellTypeVisible).Copy Range("C6")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, "C").End(xlUp).Row + 1
wsDestination.Range("C" & DestinationRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws.Range("A1:N" & LastRow).AutoFilter Field:=1
End Sub
currently the first code filters and copies table data in the parameter that I want into another worksheet, but I need a more complex version of the copy so I recorded it in macro, which is super long and looks like this:
Sub Macro8()
'
' Macro8 Macro
'
'
Sheets("INBD").Select
Range("Table1[Description]").Select
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Description]").Select
ActiveSheet.Paste
Range("D18").Select
Sheets("INBD").Select
Range("Table1[Invoice Date]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Invoice '#]").Select
ActiveSheet.Paste
Sheets("INBD").Select
Range("Table1[Invoice '#]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Invoice '#]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("INBD").Select
Range("Table1[HS Code]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[HS Code]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("INBD").Select
Range("Table1[Unit]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[M. Unit]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("Table19[Description]").Select
Application.CutCopyMode = False
Selection.Copy
Range("E13").Select
ActiveSheet.Paste
Sheets("INBD").Select
Range("Table1[QTY]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[QTY]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("INBD").Select
Range("Table1[Unit Price]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Unit Price]").Select
ActiveSheet.Paste
Sheets("INBD").Select
Range("Table1[Curr.]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Curr]").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Rows("13:22").Select
Rows("13:22").EntireRow.AutoFit
Selection.RowHeight = 30
Application.CutCopyMode = False
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
What this does is that it copies values into a table, into specific columns, below the table I wrote in a bunch of stuff and made the color of the font white, so that when it copies, the table moves the cells down hence not altering anything below the table and leaves some space in between. After this I'm going to record a macro which deletes all rows in the table and any other data in the table to clear the document for a new entry.
One solution to combine two Macros would be just to type everything from the second Macro between the first and last line and paste in where you need its execution in the first code.
The other solution would be to "Call" the second Macro from the first Code by simply typing
Call Macro8
In your example :
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("inbd")
Dim wsDestination As Worksheet: Set wsDestination = Sheets("test")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1, Criteria1:=Worksheets("test").Cells(1, 26).Value
ws.Range("f2:f" & LastRow).SpecialCells(xlCellTypeVisible).Copy Range("C6")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, "C").End(xlUp).Row + 1
wsDestination.Range("C" & DestinationRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws.Range("A1:N" & LastRow).AutoFilter Field:=1
Call Macro8 ' Or Copy Paste the whole other code here
End Sub
I still strongly advise to follow the links from the comments of Foxfire And Burns And Burns about How to avoid using Select in Excel VBA.
Application.run ("macro8") <-is what I needed, I appreciate the advice though, I don't really have any knowledge in coding, but I will try to avoid using select if i can.

Open workbook prompts multiple times

A few times a day I receive a file. I'm trying to automate it as much as possible and one part would include having the macro that lets you select a file to vlookup into (the file name is different every time). My macro runs, but for some reason it prompts you to select your file 3 times. I've tried a few variations on the code, but nothing worked. Does anyone have any insight as to why? It is prompting once when first opening the file, once when filling in the first cell with the formula, and again when the macro fills down column with the vlookup formula. I've pasted the relevant part below:
Dim MyFile As String
MyFile = Application.GetOpenFilename
Set firstWB = ActiveWorkbook
Set mySheet = ActiveSheet
Set wbLookup = Workbooks.Open(MyFile)
firstWB.Activate
mySheet.Range("T2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-18],'[wbLookup]tempemail'!R2C2:R123C20,19,0)"
Range("S1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Columns("t:t").EntireColumn.AutoFit
Columns("T:T").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
wbLookup.Close False
Range("U1").Select
ActiveCell.FormulaR1C1 = "=NOW()"
Range("U1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("u:u").EntireColumn.AutoFit
End Sub
Thanks!
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-18],'[wbLookup]tempemail'!R2C2:R123C20,19,0)"
This will not work unless wbLookup is literally the name of your file. Excel sees this and prompts you for the actual name.
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-18],'[" & wbLookup.Name & "]tempemail'!R2C2:R123C20,19,0)"
might work better
This:
Columns("T:T").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
...could be replaced by this:
Columns("T:T").Value = Columns("T:T").Value
A lot of selecting/activating is unneeded and is better avoided: How to avoid using Select in Excel VBA

Code for Multiple Sheet/Active Sheet

i'm currently working on a code that will copy data from one sheet to another (please see below),it currently works on one sheet, but now I want this code to work on multiple sheets or whatever sheet is active. Can you please assist me in modifying this code to work on multiple sheets.
Sub sbCopyRangeToAnotherSheet()
Sheets("Sheet1").Select
Range("A15:E188").Select
Selection.ClearContents
Range("A15").Select
Sheets("FCI").Select
Range("C51").Select
'Copy the data
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Activate the destination worksheet
Sheets("Sheet1").Activate
'Select the target range
Range("A15").Select
'Paste in the target destination
Sheets("Sheet1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
End Sub
May be this is what you are looking for, also you can yourself twick the code little bit to suit your requirements.
Sub sbCopyRangeToAnotherSheet()
temp = ActiveSheet.Index
Sheets(temp).Select
Range("A15:E188").Copy
Worksheets("Sheet1").Activate
k = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & k + 1).Select ' kindly change the code to suit your paste location
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
modified your code with a loop to go through all the sheets present in workbook.
let me know if this is what was required.
Sub sbCopyRangeToAnotherSheet()
Sheets("Sheet1").Select
Range("A15:E188").Select
Selection.ClearContents
Range("A15").Select
Sheets("FCI").Select
Range("C51").Select
'Copy the data
For Each Sheet In ActiveWorkbook.Sheets
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Activate the destination worksheet
Sheets("Sheet1").Activate
'Select the target range
Range("A15").Select
'Paste in the target destination
Sheets("Sheet1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Next
End Sub
as I understand by your code, you want to be able to copy data from any active sheet to FSI Sheet. if this is the case , I have done changes as in below code.
Sub sbCopyRangeToAnotherSheet()
temp = ActiveSheet.Index
Sheets(temp).Select
Range("A15:E188").Select
Selection.ClearContents
Range("A15").Select
'Sheets("FCI").Select
'ActiveSheet.Range("C51").Select
'Copy the data
'For k = 1 To ActiveWorkbook.Worksheets.Count
Worksheets(temp).Activate
Sheets(temp).Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Activate the destination worksheet
Sheets(temp).Activate
'Select the target range
Range("A15").Select
'Paste in the target destination
Sheets("FCI").Select
Range("A15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'Next
End Sub

Looping though only selected sheets to proceed several steps

I have an Excel file which contains several sheets where I have to cut-copy from one column to another.
When I use the code on one specific sheet it works perfectly, yet while I've already tried to use e.g. Sheets(Array("ThisSheet", "ThatSheet")).Select and it worked partially, because after row 131 it pastes the cut data in the wrong direction, which is odd. Nonetheless, no idea how to solve it.
Could you please help me with the code? I'd trupy appreciate it. In the comments you can find names of the specific columns only, so please simply ingore it.
Sub TABFixLoop_Main()
' TABFix Macro Loop Core Scratch
' === Declaces which tabs are in the loop ========
' === Exceptions: ES20, IT40, IT43, IT44, IT45, PT20 ===
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim Sheets As Range
Set Sheets = Sheets(Array("BE00", "CH10", "CZ00", "DK00", "ES00", "FI00", "IT00", "LU30", "NL00", "NO00", "PT00", "SE00"))
For Each ws In Sheets
Do
' Fit the columns size
ws.Activate
ws.Columns.AutoFit
' Putting value ranges in correct places:
' MMDoc #
Range("P5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("N5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ws.Columns("N:N").Select
Selection.NumberFormat = "0"
Range("P5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.ClearContents
' Age
Range("Q5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("O5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("Q5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.ClearContents
' PO Vendor
Range("R5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Application.CutCopyMode = False
Selection.Copy
Range("P5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("P5").NumberFormat = "0"
Range("R5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.ClearContents
' Business Area
Range("S5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("R5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("S5").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.ClearContents
' Remove empty columns
ws.Columns("S:T").Select
Selection.Delete Shift:=xlToLeft
' Add formula to count aging ranges
Range("U5").Select
ActiveCell.FormulaR1C1 = "=+IF(RC[-6]<=30,""0-30"",IF(RC[-6]<=60,""31-60"",IF(RC[-6]<=90,""61-90"",IF(RC[-6]<=120,""91-120"",IF(RC[-6]<=180,""121-180"",IF(RC[-6]<=365,""181-365"",IF(RC[-6]>365,"">365"","""")))))))"
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
Loop Until ws = Sheets(Sheets.Count).Active
Application.ScreenUpdating = True
End Sub
Sub test()
Dim ws As Worksheet
For Each ws In Worksheets
Select Case ws.Name
Case "BE00", "CH10", "CZ00", "DK00", "ES00", "FI00", "IT00", "LU30", "NL00", "NO00", "PT00", "SE00"
ws.Columns.AutoFit
shiftdata ws, "P", "N"
shiftdata ws, "Q", "O"
shiftdata ws, "R", "P"
With ws.Range("U5")
.FormulaR1C1 = "=+IF(RC[-6]<=30,""0-30"",IF(RC[-6]<=60,""31-60"",IF(RC[-6]<=90,""61-90"",IF(RC[-6]<=120,""91-120"",IF(RC[-6]<=180,""121-180"",IF(RC[-6]<=365,""181-365"",IF(RC[-6]>365,"">365"","""")))))))"
.Copy Destination := ws.Range(.Address & ":" & .End(xlDown).Address)
End With
Case Else
End Select
Next ws
End Sub
Sub shiftdata(ws As Worksheet, strFrom As String, StrTo As String)
Dim r As Range
Set r = ws.Range(strFrom & "5:" & strFrom & ws.Range(strFrom & "5").End(xlDown).Row)
r.Copy
ws.Range(StrTo & "5").PasteSpecial xlPasteValues
r.ClearContents
End Sub

Mass edit multiple workbooks of the same format

I'm very new to VBA (as of this morning), so excuse my ignorance. I have a few hundred Excel workbooks, all formatted exactly the same way (just with different text). I'm trying to both format and delete a few sheets within the workbooks (the same for alL).
I recorded a macro that works fine when applied individually, but I'm getting a runtime error when I try to run this as a means of mass format:
Sub LoopFiles()
Dim MyFileName, MyPath As String
Dim MyBook As Workbook
MyPath = "I:\Academic Networks\All scorecard copies, 6.18.2015"
MyFileName = Dir(MyPath & "*.xlsm")
Do Until MyFileName = ""
Workbooks.Open MyPath & MyFileName
Set MyBook = ActiveWorkbook
Application.Run "Workbook1.xlsm!ScorecardMacro"
MyBook.Save
MyBook.Close
MyFileName = Dir
Loop
End Sub
I keep getting a runtime error (9) - Subscript out of range. Any thoughts?
Here's the formatting/deleting I'm trying to apply to all my workbooks (which works fine when applied to one workbook at a time:
Sub ScorecardMacro()
'
' Scorecard Macro
'
'
Sheets.Add
Sheets("Scorecard").Select
Range("D3:D36").Select
Selection.Copy
Sheets("Sheet1").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Scorecard").Select
Range("A3:A36").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Scorecard").Select
Range("F3:I36").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Checklist").Select
Range("D4:D27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveWindow.ScrollColumn = 28
Range("AJ1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Checklist").Select
Range("A4:A27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("AJ2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Additional Information").Select
Range("A4:B14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("BH1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Program Recommendations").Select
Range("A4:D21").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("BS1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
ActiveWindow.ScrollColumn = 1
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
ActiveCell.FormulaR1C1 = _
"=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1,SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1)"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A6"), Type:=xlFillDefault
Range("A2:A6").Select
Sheets("Program Recommendations").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Additional Information").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Scorecard").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Checklist").Select
ActiveWindow.SelectedSheets.Delete
End Sub
The error shows you are trying to access something that doesn't exist.
Since you are deleting something, its better to do all you updates first, then do all the deletes in the end.
If you do some deletes in between and then update, there might be some values/sheets missing
You are referring to a named range called "filename":
"=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1,SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1)"
I suspect that name is not defined in the other workbooks.