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

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.

Related

No errors, but Macro works using F8 line by line, not when executing the full macro - excel, vba

I have 6 identical macros in one workbook. 4 out of 6 work good, but I have the same issue for the rest.
If I run the macro from debug window with F8, I have perfect , expected results. If I run a macro normally, I have not any errors, but the result is obviously wrong.
I can guess that at that case , that the macto ignores this part (all mistakes start here), but not sure
ActiveSheet.Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
ActiveSheet.Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H" & lastrow)
ActiveSheet.Range("H2:H" & lastrow).Select
The goal of the macro is to filter one tab, put a few columns in another tab; compare values from one of the columns to another tab, remove duplicates , filter and paste the results in the "Results" tab.
When I do this manually I have got 6 rows in a "Result" tab. When I run it normally, I have one row, or nothing..
Can you please kindly advise - what is wrong with this macro?
I have tried to put this line in my code (no luck) :
Application.PrintCommunication = True
I have tried to put DoEvents
ThisWorkbook before each Row, Column and Range - no luck
Many thanks in advance!!
And here is my full code:
Public lastrow As Long
Public FileName As String
Public TabName As String
Sub APP_filtering_new()
'
' APP_filtering Macro
lastrow = ActiveSheet.Range("A1048576").End(xlUp).Row
Sheets("APP-input").Select
ActiveSheet.Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AG$14878").AutoFilter Field:=2, Criteria1:=Array( _
"BRAMPTON", "VANCOUVER, CD", "VANCOUVER", _
"VANCOUVER TERMINAL"), Operator:=xlFilterValues
ActiveSheet.Columns("E:E").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("APP_output").Select
ActiveSheet.Columns("A:A").Select
ActiveSheet.Paste
Sheets("APP-input").Select
ActiveSheet.Columns("N:N").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("APP_output").Select
ActiveSheet.Columns("D:D").Select
ActiveSheet.Paste
Sheets("APP-input").Select
ActiveSheet.Columns("G:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("APP_output").Select
ActiveSheet.Columns("E:E").Select
ActiveSheet.Paste
ActiveSheet.Range("F2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = " "
ActiveSheet.Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F" & lastrow)
ActiveSheet.Range("F2:F" & lastrow).Select
ActiveSheet.Range("G2").Select
ActiveCell.FormulaR1C1 = " "
ActiveSheet.Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G" & lastrow)
ActiveSheet.Range("G2:G" & lastrow).Select
ActiveSheet.Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
ActiveSheet.Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H" & lastrow)
ActiveSheet.Range("H2:H" & lastrow).Select
ActiveSheet.Columns("H:H").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'remove duplicates
ActiveSheet.Columns("A:H").Select
Application.CutCopyMode = False
ActiveSheet.Range("A1:E" & lastrow).RemoveDuplicates Columns:=5, Header:= _
xlNo
'vlookup, IF condition
ActiveSheet.Range("I2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],container,4,FALSE)"
ActiveSheet.Range("I2").Select
Selection.AutoFill Destination:=Range("I2:I" & lastrow)
ActiveSheet.Range("I2:I" & lastrow).Select
ActiveSheet.Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-1]<RC[-2],""C. has bigger number of Containers"",IF(RC[-1]=RC[-2],""The same amount of containers"",IF(RC[-2]<RC[-1],""The C. has less amount of Containers"")))"
ActiveSheet.Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J" & lastrow)
ActiveSheet.Range("J2:J" & lastrow).Select
ActiveSheet.Range("H1").Select
ActiveCell.FormulaR1C1 = "Amt of Containers - External report"
ActiveSheet.Range("I1").Select
ActiveCell.FormulaR1C1 = "Amt of Containers - Internal report"
ActiveSheet.Range("J1").Select
ActiveCell.FormulaR1C1 = "Result (N/A means New Shipment)"
ActiveSheet.Range("H1:J1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveSheet.Range("H1:I1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("J1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("J1").Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("D1:J" & lastrow).AutoFilter Field:=7, Criteria1:=Array( _
"#N/A", "C. has bigger number of Containers", _
"The C. has less amount of Containers"), Operator:=xlFilterValues
' paste in next empty row
ActiveSheet.Rows("2:2").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Results").Select
lastrow = ActiveSheet.Range("A1048576").End(xlUp).Row
ActiveSheet.Range("A" & lastrow + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
This isn't a full answer, but e.g this block of code
ActiveSheet.Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
ActiveSheet.Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H" & lastrow)
ActiveSheet.Range("H2:H" & lastrow).Select
can be replaced by a single line
ActiveSheet.Range("H2:H" & lastrow).FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
Get rid of ActiveSheet and replace with the actual sheet name.

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

VBA Code Performance Issue

I am using a VBA macro to insert a column whereby it searches for a text character in column A.
My code runs correctly. However, the file appears like it is going to crash. I will be building on the macro and want it to run smoothly.
Is there a way to optimise my code
Code:
Sheets("Annual Rec").Select
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "General"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "=ISTEXT(RC[-1])"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
The code below does the same as yours, just without the unnecessary Select and Selection.
Option Explicit
Sub CopyColPasteVal()
Application.ScreenUpdating = False
With Sheets("Annual Rec")
.Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Columns("B:B").NumberFormat = "General"
With .Range("B2:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
.Formula = "=ISTEXT(RC[-1])"
.Copy
.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub
Try this:
Application.ScreenUpdating = False
'your code
Application.ScreenUpdating = True
And avoid Select statements, they are quite slow.

Stack Three Macros into One VBA Command

I have three macros (below) that work separately, but when I sandwich them together, only the first macro executes properly. I'm not getting an error; the other two macros just don't seem to run. Any advice on how to link them together so I can execute all at once?
Macro 1
Sub Update_Workbook()
Dim QryStr As String, cell As String
Dim a As Integer, b As Integer
Dim cellv As Variant
'Pause spreadsheet calculations until end of sub
Application.Calculation = xlManual
ActiveWorkbook.Sheets("Raw Data").Select
'Clear cells to import query
With Range("A1:O1").EntireColumn
.ClearContents
.NumberFormat = "General"
.Validation.Delete
End With
'Process SQL query string
QryStr = ActiveSheet.TextBox1.Value
Do While InStr(QryStr, "{&")
a = InStr(QryStr, "{&")
b = InStr(a, QryStr, "}")
cell = Mid(QryStr, a + 2, b - a - 2)
cellv = Range(cell).Value
If IsDate(cellv) Then
cellv = Format(cellv, "dd-mmm-yy")
End If
QryStr = Replace(QryStr, "{&" & cell & "}", cellv)
Loop
'Import data from query
With ActiveSheet.QueryTables.Add(Connection:="ODBC;DRIVER={Oracle in OraClient11g_home1};UID=xx;PWD=xx;SERVER=xx;DBQ=xx", _
Destination:=Range("A1"), Sql:=QryStr)
.MaintainConnection = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.Refresh
.Delete
End With
Finish_Sub:
Call ClearUnneededNames
Application.Calculation = xlCalculationAutomatic
End Sub
Sub ClearUnneededNames()
Dim savedNames As Integer
savedNames = 0
Do While ActiveSheet.Names.Count > savedNames
If InStr(ActiveSheet.Names(savedNames + 1).Name, "ExternalData") = 0 Then
savedNames = savedNames + 1
Else
ActiveSheet.Names(savedNames + 1).Delete
End If
Loop
End Sub
Macro 2
Sub Five_Felicia_for_MFG()
'
' Macro3 Macro
'
'
Range("A3:M3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=-18
Range(Selection, Selection.End(xlUp)).Select
Range("A3:M1010").Select
Selection.Delete Shift:=xlUp
Sheets("5Felicia").Select
Range("A3:M34").Select
Selection.Copy
Sheets("5Felicia for MFG").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("5Felicia").Select
Range("A37:M37").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A37:M692").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("5Felicia for MFG").Select
ActiveWindow.SmallScroll Down:=18
Range("A36").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-48
Columns("A:M").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$M$691").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
7, 8, 9, 10, 11, 12, 13), Header:=xlNo
End Sub
Macro 3
Sub DUMMY_ITEMS()
'
' DUMMY_ITEMS Macro
Dim LastRow As Long
Sheets("Operations").Range("H2:V73").Copy
With Sheets("Raw Data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
End With
End Sub
In VBA a Module can have several macros (or, more accurately, subroutines) in it.
But, when you call one of those macros, execution stops at the End Sub statement. Nothing else in the module will run regardless of how you "sandwich" them together within the module.
But subroutines can call other subroutines. So code like this will run all three of your macros:
Sub RunAllThree()
Update_Workbook
Five_Felicia_for_MFG
DUMMY_ITEMS
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.