Setting excel VBA Range from multiple variables - excel
I'm having trouble with the Range function. (Nearly) completed code below. I'm fairly new to VBA, so please explain the basics if you have the time. This is the line that is giving me a debug error:
Set CombinedPropRange = ThisWorkbook.Worksheets("PropFiltered").Range("A" & _
PropACount & ":J" & SplitTabName(2))
Full Code Below:
Sub FillTabsTest()
' FillTabsTest Macro
HowManyTabsDoYouNeed = 4 'If you want to add or remove Tabs, you must change this number AND add/subtract from the "TabName(1)" section below.
ReDim TabName(1 To HowManyTabsDoYouNeed) As String
'Grabs Data from Original Workbook and creates a new Workbook.
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range("A1:P1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Call WrapText
TabName(1) = "April H.,0,1000"
TabName(2) = "Christopher H.,0,1000"
TabName(3) = "Christie E.,500,500"
TabName(4) = "Cori M.,500,500"
'Places Filtered Auto Events on its own tab
Sheets("Sheet1").Select
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A:$S").AutoFilter Field:=8, Criteria1:="=COMAUTO", _
Operator:=xlOr, Criteria2:="=PERSAUTO"
ActiveSheet.Range("$A:$S").AutoFilter Field:=5, Criteria1:="=3*", Operator _
:=xlAnd
ActiveSheet.Range("$A:$S").AutoFilter Field:=9, Criteria1:=Array( _
"AUTO BODILY INJURY", "AUTO MED PAY", "AUTO PROPERTY DAMAGE", "AUTO-ENDORSEMENT", _
"AUTO-OTHER", "BODILY INJURY", "COLLISION", "COMPREHENSIVE", "LIABILITY", "OTHER", _
"RENTAL REIMBURSEMENT", "UM/UIM"), Operator:=xlFilterValues
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "AutoFiltered"
ActiveSheet.Paste
'Places Filtered Property Events on its own tab
Sheets("Sheet1").Select
Cells.Select
Application.CutCopyMode = False
ActiveSheet.ShowAllData
Cells.Select
ActiveSheet.Range("$A:$S").AutoFilter Field:=8, Criteria1:="=COMPROP", _
Operator:=xlOr, Criteria2:="=PLPROP"
ActiveSheet.Range("$A:$S").AutoFilter Field:=5, Criteria1:="=3*", Operator _
:=xlAnd
ActiveSheet.Range("$A:$S").AutoFilter Field:=12, Criteria1:="<>*FIRE*", _
Operator:=xlOr, Criteria2:="<>*SMOKE*"
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "PropFiltered"
ActiveSheet.Paste
'Begin adding the above named tabs to the workbook
For i = 1 To HowManyTabsDoYouNeed
Sheets.Add After:=Sheets(Sheets.Count)
SplitTabName = Split(TabName(i), ",")
ActiveSheet.Name = SplitTabName(0)
Next i
'Begin populating employee's sheets.
Dim AutoACount As Integer
Dim PropACount As Integer
' Dim AutoAPasteCount As Integer
Dim PropAPasteCount As Integer
Dim AutoJCount As Integer
Dim PropJCount As Integer
'Dim AutoRangeA As Range
'Dim AutoRangeJ As Range
'Dim PropRangeA As Range
'Dim PropRangeJ As Range
Dim PropAPasteCountRange As String
Dim CombinedPropRange As Range
Dim CombinedAutoRange As Range
AutoACount = 2
PropACount = 2
AutoJCount = 2
PropJCount = 2
PropAPasteCount = 2
For i = 1 To HowManyTabsDoYouNeed
SplitTabName = Split(TabName(i), ",")
If SplitTabName(1) <> "0" Then
' Set AutoRangeA = Range("A" & AutoACount)
' Set AutoRangeJ = Range("J" & SplitTabName(1))
Sheets("AutoFiltered").Select
Set CombinedAutoRange = ThisWorkbook.Worksheets("AutoFiltered").Range("A" & AutoACount & ":J" & SplitTabName(1))
CombinedAutoRange.Copy
Sheets("SplitTabName(0)").Select
ActiveSheet.Paste
AutoACount = AutoACount + SplitTabName(1)
PropAPasteCount = SplitTabName(1)
End If
If SplitTabName(2) <> "0" Then
'Set PropRangeA = Range("A" & PropACount)
'MsgBox PropRangeA
'Set PropRangeJ = Range("J" & SplitTabName(2))
PropAPasteCountRange = "A" & PropAPasteCount
'Sheets("PropFiltered").Select
Set CombinedPropRange = ThisWorkbook.Worksheets ("PropFiltered").Range("A" & PropACount & ":J" & SplitTabName(2))
CombinedPropRange.Copy
Sheets("SplitTabName(0)").Select
ThisWorkbook.Worksheets(SplitTabName(0)).Cells(PropAPasteCountRange).Select
ActiveSheet.Paste
PropACount = PropACount + SplitTabName(2)
End If
Next i
End
Related
To add the excel formulas into VBA Macro with condition
I have recorded some formulas into Macros and they are functioning properly, however I am not able to update them so that they should select the range themselves where the data ends in the last end in Column C. These 3 formulas extracts Date, File Name and Status of Files from Column A. As you see for now the range is e.g. "F3 to F313" where next time if the Data in Column C is up to C500 Range than I have to manually copy and paste the formulas. Is there anyway these 3 formulas should automatically detect the last text cell from Column C and ends there. That would be much helpful. To Extract Date Sub Macro13() 'To Extract Date ActiveCell.FormulaR1C1 = "=extractDate(RC[-1])" Range("D2").Select Selection.Copy Range("D3:D313").Select ActiveSheet.Paste Application.CutCopyMode = False End Sub To Find Status of File Sub Macro15() 'To Find Status of File ActiveCell.FormulaR1C1 = _ "=IFERROR(LOOKUP(2^15,SEARCH({""Feed"",""Feed 1"",""Feed 2""},RC[-3]),{""Feed"",""Feed 1"",""Feed 2""}),""Combine"")" Range("F2").Select Selection.Copy Range("F3:F313").Select ActiveSheet.Paste Application.CutCopyMode = False End Sub To extract File Name Sub Macro17() 'To extract File Name ActiveCell.FormulaR1C1 = _ "=IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABCD - GAMA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ALPHA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9," & _ "0},RC[-2]&""1234567890""))-1))=""ABCD - BETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""DBETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""A"",LEFT(RC[-2]," & _ "MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))="""",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABETA"",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),LEF" & _ "T(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2] & ""1234567890""))-1))))))))" Range("E2").Select Selection.Copy Range("E3:E313").Select ActiveSheet.Paste Application.CutCopyMode = False End Sub
Try this: Sub TestThis() Dim LastRow As Long, ws As Worksheet Set ws = ActiveSheet LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ws.Range("D2:D" & LastRow).FormulaR1C1 = "=extractDate(RC[-1])" ws.Range("F2:F" & LastRow).FormulaR1C1 = "=IFERROR(LOOKUP(2^15,SEARCH({""Feed"",""Feed 1"",""Feed 2""},RC[-3]),{""Feed"",""Feed 1"",""Feed 2""}),""Combine"")" ws.Range("E2:E" & LastRow).FormulaR1C1 = _ "=IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABCD - GAMA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ALPHA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+2),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9," & _ "0},RC[-2]&""1234567890""))-1))=""ABCD - BETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""DBETA "",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""A"",LEFT(RC[-2]," & _ "MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))="""",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+8),IF((LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))-1))=""ABETA"",LEFT(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2]&""1234567890""))+6),LEF" & _ "T(RC[-2],MIN(FIND({1,2,3,4,5,6,7,8,9,0},RC[-2] & ""1234567890""))-1))))))))" End Sub
Activesheet shifting away from original sheet on second iteration of the substatement
I can run this program one iteration at a time, but when I let it run on the next i, the VarCellValues come back as values from a different sheet. What would be causing the active sheet to change away from the workbook and first sheet the macro is opened from? Sub copy_financials_2022() ' ' copy_financials_2022 Macro ' Dim i As Integer Dim VarCellValue As String Dim VarCellValue2 As String Dim VarCellValue3 As String Dim VarCellValue4 As String Dim VarCellValue5 As String Dim currwbk As Workbook Set currwbk = ThisWorkbook For i = Range("A2").Value To Range("C2").Value Set currwbk = ThisWorkbook VarCellValue = Range("B" & i).Value VarCellValue2 = Range("C" & i).Value VarCellValue3 = Range("A" & i).Value VarCellValue4 = Range("D" & i).Value VarCellValue5 = Range("E" & i).Value Application.DisplayAlerts = False Workbooks.Open (Range("A3").Value & VarCellValue4 & ".xlsx") 'Workbooks.Open ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\09-30\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm") 'Workbooks.Open (Range("B3").Value & VarCellValue4) Workbooks(VarCellValue4).Activate 'inserted "Sheets(VarCellValue5).Activate" below after the third tab was active on Los Angeles Sheet (should have been the first tab) Sheets(VarCellValue5).Activate Sheets(VarCellValue5).Unprotect Password:="forecast22" Columns("A:S").Select Selection.EntireColumn.Hidden = False Workbooks.Open ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\09-30\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm") Sheets(VarCellValue2).Activate Range("A6:Q6").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Range("A6:Q88").Select Selection.Copy Workbooks(VarCellValue4).Activate Range("A6").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("B:B,D:E,G:G,I:J,L:N,K:K").Select Range("K1").Activate Selection.EntireColumn.Hidden = True Range("C7").Select 'Range("A6").Select Application.CutCopyMode = False ActiveWorkbook.Save Range("C7").Select ActiveCell.FormulaR1C1 = "Sept MTD" Range("H7").Select ActiveCell.FormulaR1C1 = "Sept YTD" Range("S8").Select ActiveCell.FormulaR1C1 = "Aug - Dec 2021" Range("A6").Select ActiveSheet.Protect Password:="forecast22" ActiveWorkbook.Save ActiveWindow.Close 'Workbooks.Close ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\05-31\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm") Next i End Sub
Instead of relying on a sheet being active, fully qualify each Range call with the appropriate workbook/worksheet. Dim currwbk As Workbook Set currwbk = ThisWorkbook Dim currWs As Worksheet Set currWs = currwbk.ActiveSheet For i = currWs.Range("A2").Value To currWs.Range("C2").Value VarCellValue = currWs.Range("B" & i).Value VarCellValue2 = currWs.Range("C" & i).Value VarCellValue3 = currWs.Range("A" & i).Value VarCellValue4 = currWs.Range("D" & i).Value VarCellValue5 = currWs.Range("E" & i).Value Dim wb As Workbook Set wb = Workbooks.Open(currWs.Range("A3").Value & VarCellValue4 & ".xlsx") With wb.Worksheets(VarCellValue5) .Unprotect Password:="forecast22" .Columns("A:S").Hidden = False ' and so on End With Next
Add columns and lookup values in two different workbooks
I have three workbooks, Workbook A, Workbook B and Workbook C. To Workbook A, I want to add two columns at the end and call them "Item code" and "store code". The existing fields in Workbook A are "Item Descr" and "Store Descr". To populate the field "Item code", I have to perform a lookup against Workbook B which has the columns "Item code" and "Item Descr". To populate the "store code" column in Workbook A, I have to perform a lookup against Workbook C which has the columns "store code"and "store Descr". This is my code so far: Sub Macro1() Dim LastRow As Long Dim LastCol As Long Dim iRow As Long Set ws = Sheet1 ' NOTE: Change this if your data is not in Sheet1. With ws LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column .Cells(1, LastCol + 1).Value = "Brand_item" .Cells(1, LastCol + 2).Value = "Brand_code" End With Range("A2").Select Selection.End(xlToRight).Select Range("G2").Select Windows("PE CLOSING OCT R2trial.xls").Activate ActiveCell.FormulaR1C1 = _ "=INDEX([PEcodez.xlsx]Sheet1!R1C2:R2338C2,MATCH(RC[-3], [PEcodez.xlsx]Sheet1!R1C1:R2338C1,0))" Range("G2").Select Selection.AutoFill Destination:=Range("G2:G2110") Range("G2:G2110").Select Range("G2").Select Selection.Copy Range(Selection, Selection.End(xlDown)).Select Application.CutCopyMode = False Selection.Copy Range("G2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H2").Select Application.CutCopyMode = False Windows("PE CLOSING OCT R2trial.xls").Activate ActiveCell.FormulaR1C1 = _ "=INDEX([PEdoorcodes.xlsx]Sheet1!R1C3:R29C3,MATCH(RC[-7],[PEdoorcodes.xlsx]Sheet1!R1C1:R29C1,0))" Range("H2").Select Selection.AutoFill Destination:=Range("H2:H2110") Range("H2:H2110").Select Range("H2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Range("H2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("H2").Select Application.CutCopyMode = False End Sub How do I include the file path of the workbooks? Update, I tried the following code to update my path: ActiveCell.FormulaR1C1 = _ "=INDEX(C:\Users\amy\Documents\amyTrial\[PEcodez.xlsx]Sheet1!$A:$A,MATCH(RC[-3],C:\Users\amy\Documents\amy\[PEcodez.xlsx]Sheet1!R1C1:R2338C1,0))" It gives me Application-defined or object-defined error.
I have created some dummy workbooks/data on my end, as you did not provide screenshots. For me, this is "Sheet1" in workbook A, this is "Sheet1" in workbook B. and this is "Sheet1" in workbook C. I use the code below to look up item descriptions and store descriptions. You will need to change the file paths to workbook B and C in the code itself (provided you place the code itself in workbook A and run it from there). Option Explicit Private Sub lookupDescriptions() Dim pathToWorkbookB As String pathToWorkbookB = "C:\Users\User\Desktop\New folder\3 workbooks\B.xlsx" ' Change this to the real file path. Dim pathToWorkbookC As String pathToWorkbookC = "C:\Users\User\Desktop\New folder\3 workbooks\C.xlsx" ' Change this to the real file path. Dim workbookB As Workbook ' Contains: Item code, item descr Set workbookB = OpenWorkbook(pathToWorkbookB) If workbookB Is Nothing Then MsgBox ("Could not locate workbook B at the path below" & vbNewLine & vbNewLine & pathToWorkbookB & vbNewLine & vbNewLine & "Check file path provided. Code will stop running now.") Exit Sub End If Dim workbookC As Workbook ' Contains: Store code, store descr Set workbookC = OpenWorkbook(pathToWorkbookC) If workbookC Is Nothing Then MsgBox ("Could not locate workbook C at the path below" & vbNewLine & vbNewLine & pathToWorkbookC & vbNewLine & vbNewLine & "Check file path provided. Code will stop running now.") Exit Sub End If ' Workbooks A and B both contain "Item code", ' Get "Item description" from workbook B for each match With ThisWorkbook.Worksheets("Sheet1") Dim itemCodesInA As Range Set itemCodesInA = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) Dim storeCodesInA As Range Set storeCodesInA = .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With With workbookB.Worksheets("Sheet1") Dim itemCodesInB As Range Set itemCodesInB = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) Dim itemDescriptionsInB As Range Set itemDescriptionsInB = .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ' Workbooks A and C both contain "Store code", ' Get "Store description" from workbook C for each match With workbookC.Worksheets("Sheet1") Dim storeCodesInC As Range Set storeCodesInC = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) Dim storeDescriptionsInC As Range Set storeDescriptionsInC = .Range("B2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) End With ' This is workbook A, change sheet name if necessary With ThisWorkbook.Worksheets("Sheet1") Dim lastRow As Long lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row Dim lastColumn As Long lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column .Cells(1, lastColumn + 1).Value2 = "Item description" With .Range(.Cells(2, lastColumn + 1), .Cells(lastRow, lastColumn + 1)) .Formula = "=INDEX(" & itemDescriptionsInB.Address(True, True, xlA1, True) & ",MATCH(" & itemCodesInA(1).Address(False, True, xlA1, False) & "," & itemCodesInB.Address(True, True, xlA1, True) & ",0))" .Value2 = .Value2 ' Comment/delete this line to keep formulas End With .Cells(1, lastColumn + 2).Value2 = "Store description" With .Range(.Cells(2, lastColumn + 2), .Cells(lastRow, lastColumn + 2)) .Formula = "=INDEX(" & storeDescriptionsInC.Address(True, True, xlA1, True) & ",MATCH(" & storeCodesInA(1).Address(False, True, xlA1, False) & "," & storeCodesInC.Address(True, True, xlA1, True) & ",0))" .Value2 = .Value2 ' Comment/delete this line to keep formulas End With End With ' Close workbooks without saving If Not (workbookB Is Nothing) Then workbookB.Close False If Not (workbookC Is Nothing) Then workbookC.Close False End Sub Private Function OpenWorkbook(ByVal fullPathToWorkbook As String) As Workbook If Len(Dir$(fullPathToWorkbook, vbNormal)) = 0 Then Exit Function End If Dim workbookName As String workbookName = VBA.Strings.Mid$(fullPathToWorkbook, VBA.Strings.InStrRev(fullPathToWorkbook, "\", -1, vbBinaryCompare) + 1) Dim outputWorkbook As Workbook On Error Resume Next Set outputWorkbook = Application.Workbooks(workbookName) On Error GoTo 0 If outputWorkbook Is Nothing Then Set outputWorkbook = Application.Workbooks.Open(fullPathToWorkbook) End If Set OpenWorkbook = outputWorkbook End Function What I get in workbook A (after running the code above) is: Owing to the differences between your workbooks and mine, it is unlikely that the code will work for you as is. You will likely need to change/tweak the code in certain places, if: your sheets in workbook A, B, C are named something other than "Sheet1" your data (including headers) has a different location/structure/layout there are blanks/missing items (that would cause the lookup to fail) Nonetheless, the code and accompanying screenshots may give you an idea on how to do it.
Choosing different ranges for different formulas
I have a worksheet which needs to calculate few formulas based on the data available, i have worked on two such formulas but it works fine but i assume, there could be a better way for this. I tried using Multirange but am not able to properly code the syntax. Sub CalculateSSL() Dim lastrow As Integer, val Dim OutputLastRow As Long Dim Lstrow Lstrow = ThisWorkbook.Sheets("All Sheet-Data").Cells(Rows.Count, "A").End(xlUp).Row Worksheets("All Sheet-Data").Activate 'the below forumla calculates the number of sales with greater than 100000 Range("L2").Select ActiveCell.FormulaR1C1 = "=COUNTIF(RC[1]:RC[8],"">100000"")" Selection.AutoFill Destination:=Range("L2:L" & Lstrow) Range("W2").Select ActiveCell.FormulaR1C1 = "=COUNTIF(RC[1]:RC[8],"">100000"")" Selection.AutoFill Destination:=Range("W2:W" & Lstrow) Range("AH2").Select ActiveCell.FormulaR1C1 = "=COUNTIF(RC[1]:RC[8],"">100000"")" Selection.AutoFill Destination:=Range("AH2:AH" & Lstrow) Range("AS2").Select ActiveCell.FormulaR1C1 = "=COUNTIF(RC[1]:RC[8],"">100000"")" Selection.AutoFill Destination:=Range("AS2:AS" & Lstrow) Range("BD2").Select ActiveCell.FormulaR1C1 = "=COUNTIF(RC[1]:RC[8],"">100000"")" Selection.AutoFill Destination:=Range("BD2:BD" & Lstrow) Range("BO2").Select ActiveCell.FormulaR1C1 = "=COUNTIF(RC[1]:RC[8],"">100000"")" Selection.AutoFill Destination:=Range("BO2:BO" & Lstrow) 'the below forumla calculates the difference between two specific items Range("V2").Select ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-3]" Range("V2").Select Selection.AutoFill Destination:=Range("V2:V" & Lstrow) Range("AG2").Select ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-3]" Range("AG2").Select Selection.AutoFill Destination:=Range("AG2:AG" & Lstrow) Range("AR2").Select ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-3]" Range("AR2").Select Selection.AutoFill Destination:=Range("AR2:AR" & Lstrow) Range("BC2").Select ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-3]" Range("BC2").Select Selection.AutoFill Destination:=Range("BC2:BC" & Lstrow) Range("BN2").Select ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-3]" Range("BN2").Select Selection.AutoFill Destination:=Range("BN2:BN" & Lstrow) End Sub
Something like this? Sub CalculateSSL() Dim lastrow As Integer, val Dim OutputLastRow As Long Dim Lstrow Dim MySheet As Worksheet, vArr(), i As Long Lstrow = ThisWorkbook.Sheets("All TMS-Data").Cells(Rows.Count, "A").End(xlUp).Row Set MySheet = ThisWorkbook.Worksheets("All Sheet-Data") 'the below forumla calculates the number of sales with greater than 100000 vArr = Array("L", "W", "AH", "AS", "BD", "BO") For i = Lbound(vArr) To Ubound(vArr) MySheet.Range("" & vArr(i) & "2:" & vArr(i) & Lstrow & "").FormulaR1C1 _ = "=COUNTIF(RC[1]:RC[8],"">100000"")" Next i 'the below forumla calculates the difference between two specific items vArr = Array("V", "AG", "AR", "BC", "BN") For i = Lbound(vArr) To Ubound(vArr) MySheet.Range("" & vArr(i) & "2:" & vArr(i) & Lstrow & "").FormulaR1C1 _ = "=RC[-1]-RC[-3]" Next i End Sub
Sub CalculateSSL() Dim lastrow As Integer, val Dim OutputLastRow As Long Dim Lstrow With ThisWorkbook.Sheets("All Sheet-Data") Lstrow = .Cells(Rows.Count, "A").End(xlUp).Row with .Range("L2:L" & Lstrow) .formula ="=COUNTIF(RC[1]:RC[8],"">100000"")" .copy destination:=array(.Range("W2"),.Range("AH2"),.Range("AS2"),.Range("BD2"),.Range("BO")) End WIth With .Range("v2:v" & Lstrow) .Formula = "=RC[-1]-RC[-3]" .Copy destination:= array(.Range("BC2"),.Range("AG2"),.Range("AR2"),.range("BN2")) End With End With End Sub EDIT Whoops - my dot references were wrong .range("BC2") is meant to expand to ThisWorkbook.Sheets("All Sheet-Data").Range("BC2") but it actually expanded to ThisWorkbook.Sheets("All Sheet-Data").Range("v2:v" & Lstrow).range("BC2") So we need to add a worksheet object to reference the sheet Dim ws as Worksheet Set ws = ThisWorkbook.Sheets("All Sheet-Data") and also it's not array it's Union .copy destination:=union(ws.Range("W2"),ws.Range("AH2"),ws.Range("AS2"),ws.Range("BD2"),ws.Range("BO"))
Copy data from multiple sheets into multiple sheets in new workbook
I know variations of this question have been asked but I can't seem to find the right code to accomplish this task. I have 2 tabs, Master Summary and Master Detail, from which I would like to copy data based on cell values in columns K and G respectively. I would like to copy data from both tabs into a new workbook if the values where these columns match. Each value needs its own workbook to be saved as the name in the cell. Thanks
Here is what I came up with: Sub CopyCMOsToOwnWorkbooks() Application.EnableCancelKey = xlDisabled Application.ScreenUpdating = False Dim CMO As Variant Dim CMOS As Variant Dim wbDest As Workbook Dim RAF As Workbook Set RAF = ThisWorkbook Dim rng As Range Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell)) CMOS = Array("Element Care", "CCACG EAST", "SCMO", "CCACG WEST", "Uphams Corner Hlth Cent", "CCC-Boston", "Vinfen", "Behavioral Hlth Ntwrk", _ "CommH Link Worc", "Long Term Care CMO", "Advocates, Inc", "CCC-Springfield", "BU Geriatric Service", "Lynn Comm HC", "CCA-BHI", "BIDJP Subacute", _ "CCC-Lawrence", "CCC-Framingham", "East Boston Neighborhoo", "BosHC 4 Homeless", "Bay Cove Hmn Srvces", "Mailhoit, Carrie", "Brightwood Hlth Ctr-Bay", _ "Romero, Michele", "Isaacs, Cindy", "McCoy, Viola", "ADRC of Greater North Shore", "Geller, Marian") For Each CMO In CMOS On Error Resume Next RAF.Activate Application.CutCopyMode = False Sheets("MASTER Summary").Select Range("F12").Select Selection.AutoFilter ActiveSheet.ListObjects("Table_Query_from_ProdServerP052").Range.AutoFilter _ Field:=11, Criteria1:=CMO Cells.Select Selection.Copy Set wbDest = Workbooks.Add(xlWBATWorksheet) ActiveSheet.Paste ActiveSheet.Cells.Select Selection.ColumnWidth = 8.29 Cells.EntireColumn.AutoFit Selection.ColumnWidth = 78.71 Cells.EntireRow.AutoFit Cells.EntireColumn.AutoFit Sheets("Sheet1").Select Sheets("Sheet1").Name = "Summary" Range("C24").Select ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = _ "Table1" Range("Table1[#All]").Select ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight13" RAF.Activate Application.CutCopyMode = False Sheets("MASTER Detail").Select Range("A2").Select Selection.AutoFilter ActiveSheet.ListObjects("Table_Query_from_ProdServerP054").Range.AutoFilter _ Field:=7, Criteria1:=CMO Cells.Select Selection.Copy wbDest.Activate Sheets.Add After:=ActiveSheet Range("A1").Select ActiveSheet.Paste Cells.Select Selection.ColumnWidth = 34.29 Selection.ColumnWidth = 50.71 Cells.EntireRow.AutoFit Cells.EntireColumn.AutoFit wbDest.Sheets("Sheet2").Select wbDest.Sheets("Sheet2").Name = "Detail" ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = _ "Table2" Range("Table2[#All]").Select ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight13" Range("A13").Select wbDest.Sheets("Summary").Select Application.DisplayAlerts = False wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _ CMO & " " & Format(Date, "mmm_dd_yyyy") Application.DisplayAlerts = True wbDest.Close Next CMO End Sub