Related
I have a piece of code that loops over a range, and checks if the cell above matches the current cell.
When it finds a different cell above the current, insert a row, and add the street name to column "A", then continue.
The problem I am having is it take a while for it to process, can you suggest a different method.
Here is the code I am currently using.
headingRange = wb.SCAA.cells(Rows.count, lastCol + 2).End(xlUp).Row
For headingID = headingRange To 7 Step -1
lookupval = wb.SCAA.cells(headingID, lastCol + 2)
With cells(headingID, lastCol + 2)
If lookupval <> .Offset(-1) Then
.EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
With cells(headingID, 1)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.ShrinkToFit = False
.ReadingOrder = xlContext
.Font.bold = True
.Font.Underline = xlUnderlineStyleSingle
.IndentLevel = 0
End With
cells(headingID, 1) = wb.SCAA.cells(headingID + 1, lastCol + 2)
End If
End With
Next headingID
Here is an example screen shot of the data that I am trying to process.
This is how the data should look after being grouped.
As Requested, here is the whole sub.
Dim wb As Workbook: Set wb = ThisWorkbook
Dim lastRowWIR, lastRowPH, lastRowCODES, lastRow, lastCol As Long
Dim address, worktypeHeading, worktype_Valuation, headingID, headingRange, i As Long
Dim add_range_PH As Range, wID_range_PH As Range, sum_range_PH, sub_range_PH As Range
Dim add_range As Range, wID_range As Range, sum_range, sub_range As Range
Dim RangeCodes, RangeWIR, RangePH
Dim contract_total As Integer
Dim myRange As Range
Dim accountCode As Object: Set accountCode = CreateObject("Scripting.Dictionary")
Dim CodeList As Object: Set CodeList = CreateObject("Scripting.Dictionary")
Dim addressList As Object: Set addressList = CreateObject("Scripting.Dictionary")
Dim addressAFA As Object: Set addressAFA = CreateObject("Scripting.Dictionary")
Dim addressValuation As Object: Set addressValuation = CreateObject("Scripting.Dictionary")
Dim addressValuationTotal As Object: Set addressValuationTotal = CreateObject("Scripting.Dictionary")
Dim ContractList As Object: Set ContractList = CreateObject("Scripting.Dictionary")
Dim PHElementTotal As Object: Set PHElementTotal = CreateObject("Scripting.Dictionary")
'''' TEST IF THE WORKS INSTRUCTION RECORD AND PAYMENT HISTORY HAVE FILTERS APPLIED, IF TRUE THEN REMOVE THEM
If wb.WIR.FilterMode = True Then wb.WIR.AutoFilter.ShowAllData
If wb.PH.FilterMode = True Then wb.PH.AutoFilter.ShowAllData
'''' CALL THE PROGRESS USERFORM SUBROUTINE
Call UserFrmProgressSub("Currently Producing Statement for: " & wb.SCAA.cells(2, 2).value, False)
'''' DO THE FIRST DEFINE FOR LAST ROWS IN DIFFERENT SHEETS, AND LAST COLUMN
lastCol = wb.SCAA.cells(6, columns.count).End(xlToLeft).Column
lastRowWIR = wb.WIR.cells(Rows.count, WIR_AccountWorktypeID).End(xlUp).Row
lastRowPH = wb.PH.cells(Rows.count, "C").End(xlUp).Row
lastRowCODES = wb.CODES.cells(Rows.count, "F").End(xlUp).Row
'''' SET THE RANGE FOR THE EMAILIST DICTIOANARY CREATION
RangePH = wb.PH.Range("C2:H" & lastRowPH).value
RangeCodes = wb.CODES.Range("F3:G" & lastRowCODES).value
RangeWIR = wb.WIR.Range(wb.WIR.cells(3, WIR_AddressCode), wb.WIR.cells(lastRowWIR, WIR_ULRecharge)).value
'''' CREATE A SCRIPTING DICTIONARY TO HOLD THE ACCOUNT CODES (KEY:C, VALUE:CYCLICAL)
For i = LBound(RangeCodes) To UBound(RangeCodes, 1)
'''' IF THE SUBCONTRACTOR IS NOT IN THE DICTIONARY THEN ADD IT
If Not accountCode.exists(RangeCodes(i, 1)) Then accountCode.add RangeCodes(i, 1), RangeCodes(i, 2)
Next i
'''' CRAEATE MULTIPLE DICTIONARYS FROM THE WORKS INSTRUCTION RECORD
For i = LBound(RangeWIR) To UBound(RangeWIR, WIR_AddressCode)
'''' ONLY ADD ITEMS TO THE RELEVANT DICTONARY IF THE SUBCONTRACTOR MATCHES THE SELECTED
If RangeWIR(i, WIR_SubContractor) = cells(2, 2) Then
'''' PRODUCE A CODE LIST FROM THE WIR BASED ON THE ACCOUNT WORKTYPE ID, THEN GET THE MATCHING VALUE FROM THE ACCONTCODE LIST KEYS FROM WIR, VALUE FROM CODELIST(KEY:L, VALUE:LIFECYLCE)
If Not CodeList.exists(RangeWIR(i, WIR_AccountWorktypeID)) Then CodeList.add RangeWIR(i, WIR_AccountWorktypeID), accountCode(RangeWIR(i, WIR_AccountWorktypeID))
'''' CREATE AND ADDRESS LIST WITH THE ADDRESS AS THE KEY, CONTACT, STREET AND PROPERTY NUMBER MAKE UP THE VALUE
If Not addressList.exists(RangeWIR(i, WIR_AddressCode)) Then addressList.add RangeWIR(i, WIR_AddressCode), RangeWIR(i, WIR_Contract) & "|" & RangeWIR(i, WIR_Street) & "|" & Left(RangeWIR(i, WIR_AddressCode), InStr(RangeWIR(i, WIR_AddressCode), " "))
'''' CREATE A DICTIONARY FOR THE CONTRACTS, EITHER PFI1, PFI2 OR BOTH
If Not ContractList.exists(RangeWIR(i, WIR_Contract)) Then ContractList.add RangeWIR(i, WIR_Contract), RangeWIR(i, WIR_Contract)
'''' DEFINE THE KEYS USED FOR THE ADDRESSAFA DICTONARY ADDRESS AND ACCOUNTWORKTYPE (14 ALMORAH ROAD|CYCLICAL)
key = RangeWIR(i, WIR_AddressCode) & "|" & CodeList(RangeWIR(i, WIR_AccountWorktypeID))
'''' THE ADDRESSAFA IS THE KEY AND THE RML ORDER VALUE FOR THAT ADDRESS AND CODE
If Not addressAFA.exists(key) Then '''' IF THAT KEY IS NOT ALREADY IN THE DICTIONARY THE ADD IT WITH THE VALE
addressAFA.add key, Round(RangeWIR(i, WIR_RMLOrderValue), 2)
Else '''' IF THE KEY IS IN THE DICTIONATY THE ADD THE NEW VALUE WITH WHATS ALREADY IN THE DICTIONARY
addressAFA(key) = addressAFA(key) + Round(RangeWIR(i, WIR_RMLOrderValue), 2)
End If
End If
Next i
'''' CRAEATE MULTIPLE DICTIONARYS FROM THE PAYMENT HISTORY
For i = LBound(RangePH) To UBound(RangePH, 1)
If RangePH(i, 2) = cells(2, 2) Then
key = RangePH(i, 1) & "|" & CodeList(RangePH(i, 3))
'''' TOTAL VALUE FOR ADDRESS & ELEMTENT (CYCLICAL)
If Not addressValuation.exists(key) Then
addressValuation.add key, Round(RangePH(i, 6), 2)
Else
addressValuation(key) = addressValuation(key) + Round(RangePH(i, 6), 2)
End If
'''' TOTAL VALUE FOR ADDRESS
If Not addressValuationTotal.exists(RangePH(i, 1)) Then
addressValuationTotal.add RangePH(i, 1), Round(RangePH(i, 6), 2)
Else
addressValuationTotal(RangePH(i, 1)) = addressValuationTotal(RangePH(i, 1)) + Round(RangePH(i, 6), 2)
End If
'''' PRODUCE A CODE LIST FROM THE WIR BASED ON THE ACCOUNT WORKTYPE ID, THEN GET THE MATCHING VALUE FROM THE ACCONTCODE LIST KEYS FROM WIR, VALUE FROM CODELIST(KEY:L, VALUE:LIFECYLCE)
If Not PHElementTotal.exists(accountCode(RangePH(i, 3))) Then
PHElementTotal.add accountCode(RangePH(i, 3)), Round(RangePH(i, 6), 2)
Else
PHElementTotal(accountCode(RangePH(i, 3))) = PHElementTotal(accountCode(RangePH(i, 3))) + Round(RangePH(i, 6), 2)
End If
If Not PHElementTotal.exists("Total") Then
PHElementTotal.add "Total", Round(RangePH(i, 6), 2)
Else
PHElementTotal("Total") = PHElementTotal("Total") + Round(RangePH(i, 6), 2)
End If
End If
Next i
'''' SET THE ACCOUNTCODE DICTIONATY TO NOTHING TO FREE MEMORY (NOT USED AGAIN IN ROUTINE)
Set accountCode = Nothing
'''' TEST IF THE CODELIST HAS A COUNT OF 0, IF TRUE THE SUBCONTRACTO HAD NO WORK ISSUED TO THEN AND NOTHING PAID TO THEN. EXIT THE SUB
If CodeList.count = "0" Then
MsgBox wb.SCAA.cells(2, 2).value & " has had no works issued to them." & vbLf & "A statement cannot be produced!", vbCritical, "SubContractor Statement Error"
Exit Sub
End If
'''' CLEAR THE SHEET BEFORE STARTING
wb.SCAA.Rows("4:" & wb.SCAA.cells(Rows.count, lastCol).End(xlUp).Row + 10).Clear
'''' CALL THE SUBROUTINE TO CREATE THE SHEET HEADINGS
Call createSCAccountHeadings1(CodeList.count, CodeList)
'''' REDEFINE THE LAST COLUMN AFTER THE HEADINGS HAVE BEEN CREATED
lastCol = wb.SCAA.cells(6, columns.count).End(xlToLeft).Column
'''' LOOP OVER THE ADDRESS LIST, AND SPLIT THE ITEM, TO ADD THE ADDRESS, PFI, PROPERTY NUMBER AND STREET TO SHEET
tableStart = 7
For Each key In addressList.keys
wb.SCAA.cells(tableStart, 1) = key
wb.SCAA.cells(tableStart, 2) = Split(addressList(key), "|")(0)
wb.SCAA.cells(tableStart, lastCol + 2) = Split(addressList(key), "|")(1)
wb.SCAA.cells(tableStart, lastCol + 1) = Split(addressList(key), "|")(2)
tableStart = tableStart + 1
Next key
'''' DEFINE THE LASTROW
lastRow = wb.SCAA.cells(Rows.count, 1).End(xlUp).Row
'''' APPLY INDENTS TO THE ADDRESS'S AND AUTOFIT COLUMN 1
wb.SCAA.Range("A7:A" & lastRow).InsertIndent 2
wb.SCAA.columns(1).AutoFit
'''' SET THE RANGES IN FOR THE SUM IF FUNCTIONS USED.
Set add_range = wb.WIR.columns(WIR_AddressCode)
Set wID_range = wb.WIR.columns(WIR_AccountWorktypeID)
Set sub_range = wb.WIR.columns(WIR_SubContractor)
Set sum_range = wb.WIR.columns(WIR_RMLOrderValue)
Set add_range_PH = wb.PH.Range("C:C")
Set wID_range_PH = wb.PH.Range("E:E")
Set sub_range_PH = wb.PH.Range("D:D")
Set sum_range_PH = wb.PH.Range("H:H")
'''' DEFINE MYRANGE
Set myRange = Range(cells(3, 1), cells(lastRow, lastCol))
'''' LOOP OVER THE ADDRESS AND WORKTYPE(COLUMNS), AND ADD VALUES AND FORMULAS
For address = 7 To lastRow
addressIns = wb.SCAA.cells(address, 1).value
For worktypeHeading = 3 To myRange.columns.count
Set wtHeading = wb.SCAA.cells(6, worktypeHeading)
Select Case True
Case worktypeHeading - 2 <= CodeList.count
If IsEmpty(addressAFA(addressIns & "|" & wtHeading)) Then
wb.SCAA.cells(address, worktypeHeading) = 0
Else
wb.SCAA.cells(address, worktypeHeading) = Format(addressAFA(addressIns & "|" & wtHeading), "Standard")
End If
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Case worktypeHeading - 2 = CodeList.count + 1
wb.SCAA.cells(address, worktypeHeading).value = Round(Application.WorksheetFunction.Sum(Range(cells(address, 3), cells(address, worktypeHeading - 1))), 2)
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Case worktypeHeading - 2 = CodeList.count + 2
If cells(address, worktypeHeading - 1) = "0" And (addressValuationTotal(addressIns) = "0" Or IsEmpty(addressValuationTotal(addressIns))) Then
wb.SCAA.cells(address, worktypeHeading).value = "0"
Else
wb.SCAA.cells(address, worktypeHeading).value = addressValuationTotal(addressIns) / cells(address, worktypeHeading - 1)
End If
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "0.00%"
wb.SCAA.cells(address, "AAA").value = wb.SCAA.cells(address, worktypeHeading)
wb.SCAA.columns(worktypeHeading).AutoFit
Case worktypeHeading - 2 > CodeList.count And worktypeHeading - 2 < myRange.columns.count - 2
If IsEmpty(addressValuation(addressIns & "|" & wtHeading)) Then
totalValuation = 0
Else
totalValuation = addressValuation(addressIns & "|" & wtHeading)
End If
myformula = "=Round(IF(" & cells(address, (worktypeHeading - (CodeList.count + 2))).address(False, False) & "=" & totalValuation & "," & totalValuation & "," & "SUM(" & cells(address, (worktypeHeading - (CodeList.count + 2))).address(False, False) & "*" & cells(address, CodeList.count + 4).address(False, False) & ")),2)"
wb.SCAA.cells(address, worktypeHeading).formula = myformula
wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Case worktypeHeading - 2 = myRange.columns.count - 2
wb.SCAA.cells(address, lastCol).formula = "=round(sum(" & cells(address, 5 + CodeList.count).address(False, False) & ":" & cells(address, worktypeHeading - 1).address(False, False) & "),2)"
wb.SCAA.cells(address, lastCol).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
End Select
Next worktypeHeading
Next address
'''' SET THE BELOW SCRIPTING DICTIONARYS TO NOTHING, TO FREE MEMORY
Set addressList = Nothing
Set addressAFA = Nothing
Set addressValuation = Nothing
Set addressValuationTotal = Nothing
'''' REDEFINE THE LAST ROW
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row
'''' TRANSPOSE THE CONTRACT LIST ON TO THE SHEET UNDER THE ADDRESS
wb.SCAA.Range("B" & lastRow + 2).Resize(ContractList.count, 1) = WorksheetFunction.Transpose(ContractList.keys)
'''' SORT THE CONTRACT LIST A - Z
If ContractList.count <> 1 Then wb.SCAA.Range("B" & lastRow + 2 & ":B" & lastRow + 2 + (ContractList.count - 1)).Sort Key1:=cells(lastRow + 2, 2), Order1:=xlAscending, Header:=xlNo
'''' DEFINE THE LAST ROW IN COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
'''' ADD "TOTAL" TO THE SHEET
wb.SCAA.cells(lastRowB + 2, 2) = "TOTAL"
'''' LOOP OVER THE CONTRACT LIST AT BOTTOM AND TOTAL, AND ADD FORMULAS THERE APPRIOPRIATE
For contract_total = lastRow + 2 To lastRowB + 2
For worktypeHeading = 3 To myRange.columns.count
Set wtHeading = wb.SCAA.cells(6, worktypeHeading)
If contract_total = lastRowB + 1 Then Exit For
If wtHeading.Offset(-1) <> "PROGRESS" Then
If contract_total <> lastRowB + 2 Then
wb.SCAA.cells(contract_total, worktypeHeading).formula = "=round(sumif(" & cells(7, 2).address & ":" & cells(lastRow, 2).address & "," & cells(contract_total, 2).address & "," & cells(7, worktypeHeading).address & ":" & cells(lastRow, worktypeHeading).address & "),2)"
wb.SCAA.cells(contract_total, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Else
wb.SCAA.cells(lastRowB + 2, worktypeHeading).formula = "=round(Sum(" & cells(lastRowB - 1, worktypeHeading).address & ":" & cells(lastRowB, worktypeHeading).address & "),2)"
wb.SCAA.cells(lastRowB + 2, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
End If
End If
Next worktypeHeading
Next contract_total
'''' RE-DEFINE THE LAST ROW IN COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
'''' ADD TWO HEADINGS
wb.SCAA.cells(lastRowB + 2, 3 + CodeList.count) = "TOTAL ALREADY PAID"
wb.SCAA.cells(lastRowB + 4, 3 + CodeList.count) = "TOTAL CHANGED"
'''' ADD THE FORMULAS TO THE TOTAL ALDREAY PAID, AND TOTAL CHANGED
For worktype_Valuation = CodeList.count + 5 To myRange.columns.count
worktype_value = wb.SCAA.cells(6, worktype_Valuation)
If IsEmpty(PHElementTotal(worktype_value)) Or PHElementTotal(worktype_value) = 0 Then
tempTotal = 0
Else
tempTotal = PHElementTotal(worktype_value)
End If
If worktype_value <> "Total" Then
wb.SCAA.cells(lastRowB + 2, worktype_Valuation) = tempTotal
wb.SCAA.cells(lastRowB + 2, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).formula = "=round(sum(" & cells(lastRowB, worktype_Valuation).address & ":" & cells(lastRowB, worktype_Valuation).address & ",-" & cells(lastRowB + 2, worktype_Valuation).address & "),2)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
Else
wb.SCAA.cells(lastRowB + 2, worktype_Valuation) = tempTotal
wb.SCAA.cells(lastRowB + 2, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).formula = "=round(sum(" & cells(lastRowB, worktype_Valuation).address & ":" & cells(lastRowB, worktype_Valuation).address & ",-" & cells(lastRowB + 2, worktype_Valuation).address & "),2)"
wb.SCAA.cells(lastRowB + 4, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
End If
Next worktype_Valuation
Set PHElementTotal = Nothing
'''' CALL THE SORTING SUB ROUTINE
Call sortData(wb.SCAA, 7, (lastRow), (lastCol + 2), False, (lastCol + 1))
'''' LOOP OVER THE ROWS, AND SEPERATE THE ADDRESS INTO SREETS
headingRange = wb.SCAA.cells(Rows.count, lastCol + 2).End(xlUp).Row
For headingID = headingRange To 7 Step -1
lookupval = wb.SCAA.cells(headingID, lastCol + 2)
With cells(headingID, lastCol + 2)
If lookupval <> .Offset(-1) Then
.EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
With cells(headingID, 1)
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.ShrinkToFit = False
.ReadingOrder = xlContext
.Font.bold = True
.Font.Underline = xlUnderlineStyleSingle
.IndentLevel = 0
End With
cells(headingID, 1) = wb.SCAA.cells(headingID + 1, lastCol + 2)
End If
End With
Next headingID
'''' ONCE ADDRESS'S HAVE BEEN SORTED AND ADDRESS'S GROUPED INTO STREETS, CLEAR THE STREET HAS PROPERTY NUMBER IN THE LAST 2 COLUMNS
With Union(columns(lastCol + 1), columns(lastCol + 2))
.ClearContents
End With
'''' REFINE LAST ROW: COLUMN A, AND LAST ROW B: COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row
'''' APPLY BORDERS TO THE SHEET, AND FORMAT
With wb.SCAA
With Union(Range(cells(7, 1), cells(lastRow, lastCol)), _
Range(cells(lastRowB, 2), cells(lastRowB, CodeList.count + 3)), _
Range(cells(lastRowB, 5 + CodeList.count), cells(lastRowB, lastCol)), _
Range(cells(lastRow + 2, 2), cells(lastRow + 1 + ContractList.count, 2 + CodeList.count + 1)), _
Range(cells(lastRow + 2, 5 + CodeList.count), cells(lastRow + 1 + ContractList.count, lastCol)), _
Range(cells(lastRowB + 2, 5 + CodeList.count), cells(lastRowB + 2, lastCol)), _
Range(cells(lastRowB + 4, 5 + CodeList.count), cells(lastRowB + 4, lastCol)))
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThin
With Range(cells(7, 2), cells(lastRowB, 2))
.HorizontalAlignment = xlVAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
With Union(Range(cells(7, 1), cells(lastRow, 1)), _
Range(cells(7, 2), cells(lastRow, 2)), _
Range(cells(7, 4 + CodeList.count), cells(lastRow, 4 + CodeList.count)))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThick
End With
End With
End With
'''' LOOP OVER ALL THE ADDRESS'S AND APPLY CONDITIONAL FORMATTING
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row
For address = 7 To lastRow
If IsEmpty(cells(address, 4 + CodeList.count).value) = False Then
With wb.SCAA.Range(wb.SCAA.cells(address, 1), wb.SCAA.cells(address, lastCol))
.FormatConditions.add Type:=xlExpression, Formula1:="=" & cells(address, 4 + CodeList.count).address(False) & ">1"
.FormatConditions(1).Interior.Color = RGB(215, 150, 148)
.FormatConditions(1).StopIfTrue = False
.FormatConditions.add Type:=xlExpression, Formula1:="=" & cells(address, 4 + CodeList.count).address(False) & "<>" & wb.SCAA.cells(address, "AAA").address(False) & ""
.FormatConditions(2).Interior.Color = RGB(196, 215, 155)
.FormatConditions(2).StopIfTrue = False
End With
End If
Next address
wb.SCAA.Range(columns(2), columns(lastCol)).ColumnWidth = 14
'''' RE-DEFINE THE LAST ROW B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
'''' LOCK ALL THE CELLS IN SHEET
wb.SCAA.Range(wb.SCAA.cells(1, 1), wb.SCAA.cells(lastRowB + 4, lastCol)).Locked = True
'''' UNLOCK THE PROGRESS COLUMN TO BE ABLE TO CHANGE THE PERCENTAGES
wb.SCAA.Range(wb.SCAA.cells(7, 4 + CodeList.count), wb.SCAA.cells(wb.SCAA.cells(Rows.count, "A").End(xlUp).Row, 4 + CodeList.count)).Locked = False
'''' SET CONTRACT LIST AND CODE LIST TO NOTHING TO AVOID MEMORY LEAKS
Set ContractList = Nothing
Set CodeList = Nothing
Just a thought but you have a LOT of variables defined as the variant type:
For example, in the declaration line you have:
Dim lastRowWIR, lastRowPH, lastRowCODES, lastRow, lastCol As Long
Here, only lastCol is defined as Long, all the rest are variant type, that's a VBA quirk.
Redefining all as set types where possible may help your process speed.
I currently have a VBA script which generates a combined chart from some data. My manager has requested that the "grand total" column (a sum of all the other columns) be present in the data table below. However, he does not want it present in the graph itself. I know that were I doing this manually, I would be able to double-click the circled column and set its Fill to "No Fill," but I cannot figure how how to do this in VBA. Note I am not trying to hide the entire series, just the circled column in the picture below.
What I have:
Picture of Incorrect Chart
What I'm trying to accomplish:
Picture of Corrected Chart
Thanks for your time!
EDIT: Plotting Code:
'Plotting!
Dim dblMax As Double
dblMax = Application.WorksheetFunction.Max(dpws.Range("B2:P4"))
Dim chrt As Chart
Set chrt = pws.Shapes.AddChart.Chart
With chrt
.ChartArea.Left = 200
.ChartArea.Top = 0
.ChartArea.Height = 500
.ChartArea.Width = 800
.Legend.Position = xlLegendPositionBottom
.ChartType = xlColumnStacked
.HasDataTable = True
.SetSourceData Source:=dpws.UsedRange
.SeriesCollection("Forecasted % Complete").AxisGroup = 2
.SeriesCollection("Forecasted % Complete").ChartType = xlLineMarkers
.SeriesCollection("Forecasted % Complete").MarkerStyle = xlMarkerStyleSquare
.SeriesCollection("Cumulative").ChartType = xlLine
.SeriesCollection("Cumulative").Format.Line.Visible = False
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dblMax + dblMax * 0.2
.Axes(xlValue, xlSecondary).MinimumScale = 0
.Axes(xlValue, xlSecondary).MaximumScale = 1
End With
And below you will find the full code.
Sub MyCode()
Dim dws As Worksheet
Dim pws As Worksheet
Dim start As Range
Dim dataRange As Range
Dim pvtCache As PivotCache
Dim pvt As PivotTable
Dim startPvt As String
Dim lastCol As Integer
'Create ChartBin, ChartDate columns.
Set dws = Sheets("Sheet1")
With dws
lastCol = dws.Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(1, lastCol + 1).Value = "Chart_Bin"
.Cells(1, lastCol + 2).Value = "Chart_Date_Group"
End With
'Populate Chart Columns
Dim i As Long
Dim thisMonth As Integer
Dim hwswDateCol As Long
Dim statusCol As Long
Dim hwswDateGrpCol As Long
hwswDateCol = 162
statusCol = 13
hwswDateGrpCol = 163 'Really should search for these column titles.
thisMonth = Month(Date)
With dws
For i = 2 To .UsedRange.Rows.Count Step 1
.Cells(i, lastCol + 2).Value = .Cells(i, hwswDateGrpCol).Value
'If complete...
If (.Cells(i, statusCol) = "Complete") Then
.Cells(i, lastCol + 1).Value = "Complete"
'If not complete, date passed...
ElseIf (thisMonth - Month(.Cells(i, hwswDateCol)) > 0) Then
.Cells(i, lastCol + 1).Value = "Missed"
Else
.Cells(i, lastCol + 1).Value = "Forecasted"
End If
Next i
End With
'Copy just data we need to reduce pivot size.
Set rws = Sheets.Add
rws.Name = "Raw"
dws.Columns(1).Copy Destination:=rws.Columns(1)
dws.Columns(2).Copy Destination:=rws.Columns(2)
dws.Columns(4).Copy Destination:=rws.Columns(3)
dws.Columns(8).Copy Destination:=rws.Columns(4)
dws.Columns(10).Copy Destination:=rws.Columns(5)
dws.Columns(22).Copy Destination:=rws.Columns(6)
dws.Columns(131).Copy Destination:=rws.Columns(7)
dws.Columns(11).Copy Destination:=rws.Columns(8)
dws.Columns(101).Copy Destination:=rws.Columns(9)
dws.Columns(lastCol + 1).Copy Destination:=rws.Columns(10)
dws.Columns(lastCol + 2).Copy Destination:=rws.Columns(11)
'Create pivots.
Set pws = Sheets.Add
pws.Name = "Pivot"
Set start = rws.Range("A1")
Set dataRange = rws.Range(start, start.SpecialCells(xlLastCell))
startPvt = pws.Name & "!" & pws.Range("T1").Address(ReferenceStyle:=x1R1C1)
Set pvtCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)
Set pvt = pvtCache.CreatePivotTable(TableDestination:=startPvt, TableName:="Market Totals")
pvt.PivotFields("Chart_Date_Group").Orientation = xlColumnField
pvt.PivotFields("Chart_Bin").Orientation = xlRowField
pvt.PivotFields("JOB NUMBER").Orientation = xlDataField
'Add slicers.
Dim sl As Slicer
Dim sls As Slicers
Dim slcs As SlicerCaches
Dim slc As SlicerCache
Set slcs = ActiveWorkbook.SlicerCaches
Set sls = slcs.Add(pws.PivotTables(1), "Carrier Type", "Carrier_Type").Slicers
Set sl = sls.Add(pws, , "Carrier_Type", "Carrier Type", 0, 0, 200, 75)
Set sls = slcs.Add(pws.PivotTables(1), "AVP", "AVP").Slicers
Set sl = sls.Add(pws, , "AVP", "AVP Type", 75, 0, 100, 250)
Set sls = slcs.Add(pws.PivotTables(1), "MARKET_RPA", "MARKET_RPA").Slicers
Set sl = sls.Add(pws, , "MARKET_RPA", "MARKET_RPA", 75, 100, 100, 400)
Set sls = slcs.Add(pws.PivotTables(1), "Driver", "Driver").Slicers
Set sl = sls.Add(pws, , "Driver", "Driver", 325, 0, 100, 150)
Set sls = slcs.Add(pws.PivotTables(1), "VENDOR", "VENDOR").Slicers
Set sl = sls.Add(pws, , "VENDOR", "VENDOR", 475, 0, 100, 150)
Set sls = slcs.Add(pws.PivotTables(1), "Hardware Location", "Hardware_Location").Slicers
Set sl = sls.Add(pws, , "Hardware_Location", "Hardware Location", 475, 100, 100, 200)
Set sls = slcs.Add(pws.PivotTables(1), "IWOS Flag", "IWOS_Flag").Slicers
Set sl = sls.Add(pws, , "IWOS_Flag", "IWOS Flag", 675, 0, 200, 125)
'Add data to data prep worksheet.
Dim dpws As Worksheet
Set dpws = Sheets.Add
dpws.Name = "Data Prep"
dpws.Cells(2, 1).Value = "Complete"
dpws.Cells(3, 1).Value = "Forecasted"
dpws.Cells(4, 1).Value = "Missed"
dpws.Cells(5, 1).Value = "Cumulative"
dpws.Cells(6, 1).Value = "Forecasted % Complete"
dpws.Cells(1, 2).Value = "2015"
dpws.Cells(1, 3).Value = "2016 Jan"
dpws.Cells(1, 4).Value = "2016 Feb"
dpws.Cells(1, 5).Value = "2016 Mar"
dpws.Cells(1, 6).Value = "2016 Apr"
dpws.Cells(1, 7).Value = "2016 May"
dpws.Cells(1, 8).Value = "2016 Jun"
dpws.Cells(1, 9).Value = "2016 Jul"
dpws.Cells(1, 10).Value = "2016 Aug"
dpws.Cells(1, 11).Value = "2016 Sep"
dpws.Cells(1, 12).Value = "2016 Oct"
dpws.Cells(1, 13).Value = "2016 Nov"
dpws.Cells(1, 14).Value = "2016 Dec"
dpws.Cells(1, 15).Value = "2017"
dpws.Cells(1, 16).Value = "2018"
For i = 2 To dpws.UsedRange.Columns.Count Step 1
dpws.Cells(2, i).Value = WorksheetFunction.IfError(pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Complete", "Chart_Date_Group", dpws.Cells(1, i).Value), 0)
dpws.Cells(3, i).Value = WorksheetFunction.IfError(pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Forecasted", "Chart_Date_Group", dpws.Cells(1, i).Value), 0)
dpws.Cells(4, i).Value = WorksheetFunction.IfError(pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Missed", "Chart_Date_Group", dpws.Cells(1, i).Value), 0)
Next i
dpws.Cells(1, 17).Value = "Grand Total"
dpws.Cells(2, i) = pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Complete")
dpws.Cells(3, i) = pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Forecasted")
dpws.Cells(4, i) = pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Missed")
dpws.Cells(5, i) = pvt.GetPivotData("JOB NUMBER")
'Calculate percentages/cumulatives.
Dim grandTotalCol As Integer
Dim percentageRow As Integer
Dim sumRow As Integer
Dim prevValue As Double
prevValue = 0
grandTotalCol = i
sumRow = 5
percentageRow = 6
With dpws
For i = 2 To dpws.UsedRange.Columns.Count Step 1
.Cells(sumRow, i).Value = WorksheetFunction.Sum(.Range(.Cells(2, i), .Cells(4, i))) + prevValue
prevValue = .Cells(sumRow, i).Value
If i = dpws.UsedRange.Columns.Count - 1 Then
prevValue = 0
End If
.Cells(percentageRow, i).Value = dpws.Cells(sumRow, i).Value / dpws.Cells(5, grandTotalCol).Value
.Cells(percentageRow, i).NumberFormat = "0%"
Next i
End With
'Plotting!
Dim dblMax As Double
dblMax = Application.WorksheetFunction.Max(dpws.Range("B2:P4"))
Dim chrt As Chart
Set chrt = pws.Shapes.AddChart.Chart
With chrt
.ChartArea.Left = 200
.ChartArea.Top = 0
.ChartArea.Height = 500
.ChartArea.Width = 800
.Legend.Position = xlLegendPositionBottom
.ChartType = xlColumnStacked
.HasDataTable = True
.SetSourceData Source:=dpws.UsedRange
.SeriesCollection("Forecasted % Complete").AxisGroup = 2
.SeriesCollection("Forecasted % Complete").ChartType = xlLineMarkers
.SeriesCollection("Forecasted % Complete").MarkerStyle = xlMarkerStyleSquare
.SeriesCollection("Cumulative").ChartType = xlLine
.SeriesCollection("Cumulative").Format.Line.Visible = False
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dblMax + dblMax * 0.2
.Axes(xlValue, xlSecondary).MinimumScale = 0
.Axes(xlValue, xlSecondary).MaximumScale = 1
End With
End Sub
Just added 2 lines of code to your original 'Plotting Section
Dim dblMax As Double
dblMax = Application.WorksheetFunction.Max(dpws.Range("B2:P4"))
Dim chrt As Chart
Set chrt = pws.Shapes.AddChart.Chart
With chrt
.ChartArea.Left = 200
.ChartArea.Top = 0
.ChartArea.Height = 500
.ChartArea.Width = 800
.Legend.Position = xlLegendPositionBottom
.ChartType = xlColumnStacked
.HasDataTable = True
.SetSourceData Source:=dpws.UsedRange
.SeriesCollection("Forecasted % Complete").AxisGroup = 2
.SeriesCollection("Forecasted % Complete").ChartType = xlLineMarkers
.SeriesCollection("Forecasted % Complete").MarkerStyle = xlMarkerStyleSquare
.SeriesCollection("Cumulative").ChartType = xlLine
' Added the 2 lines below
.SeriesCollection("Cumulative").Format.Fill.Visible = msoFalse
.SeriesCollection("Cumulative").Format.Line.Visible = msoFalse
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dblMax + dblMax * 0.2
.Axes(xlValue, xlSecondary).MinimumScale = 0
.Axes(xlValue, xlSecondary).MaximumScale = 1
nd With
I need to copy a lot of rows. I tried to do something.copy something else.paste but it's extremely slow
I tried to do
Range(..).value(formula) = Range(..).value(formula) but its not so good because i have a date there that turn to ######
I need a faster way to do this copy/paste
This is my code:
Function Last_Col(k As Long) As Long
Last_Col = Cells(k, Columns.Count).End(xlToLeft).Column
End Function
Function Last_Col_Doc() As Long
Last_Col_Doc = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Column
End Function
Function Is_Grouped(i As Long) As Boolean
Is_Grouped = (Cells(i, 2).Rows.OutlineLevel > 1)
End Function
Function Is_Bold(i As Long) As Boolean
Is_Bold = Cells(i, 2).Font.Bold
End Function
Function Print_NA(i As Long, k As Long) As Boolean
Range(Cells(i, 21), Cells(i, 21 + k - 2)).Value = "NA"
End Function
Function Last_Row() As Long
Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
End Function
Sub EditParanoia()
Dim FrstBlkRow As Long
Dim flag As Boolean
Dim i As Long
Dim HeadLen As Long
FrstBlkRow = Last_Col(1) + 1
If FrstBlkRow < 25 Then 'first edit
flag = True
i = 2
Do While flag
If Is_Bold(i) Then
flag = False
Else
i = i + 1
End If
Loop
HeadLen = Last_Col(i)
Range(Cells(i, 2), Cells(i, HeadLen)).Copy
Range(Cells(1, FrstBlkRow), Cells(1, FrstBlkRow + HeadLen - 2)).PasteSpecial
Else
FrstBlkRow = 21
HeadLen = 10
End If
Dim j As Long
For i = 2 To Last_Row Step 1
If Not Is_Grouped(i) And Not Is_Grouped(i + 1) And Cells(i, FrstBlkRow + 1).Value = vbNullString Then
'if not part of group
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 2)).Value = "NA"
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) And Is_Grouped(i + 2) And Not Is_Grouped(i + 3) Then
'if Part of group of 1 val
Range(Cells(i + 2, 2), Cells(i + 2, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 3)).PasteSpecial
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) Then
'if part of group of more then one val
j = 1
Do Until Is_Grouped(i + j) And Not Is_Grouped(i + j + 1)
'j will get the langth of any group
j = j + 1
Loop
'past the relevant cell in the right place
Range(Cells(i + 2, 2), Cells(i + 2 + j - 1 - 1, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i + j - 1 - 1, FrstBlkRow + HeadLen - 3)).PasteSpecial
'past the head respectively
Range(Cells(i, 1), Cells(i, 20)).Copy
Range(Cells(i + 1, 1), Cells(i + j - 2, FrstBlkRow - 1)).PasteSpecial
End If
Next
End Sub
When you say you've tried "Range(..).value(formula) = Range(..).value(formula)", what do you mean? You should be able to set two ranges equal to eachother:
Say A1:A10 has "Batman, 10-01-2015" and you want to copy that range to B1:B10, Range("B1:B10").Value = Range("A1:A10").Value. You can't do that? I tried it with dates, and it set the B range values to dates, no reformatting necessary.
I also notice in your code, you PasteSpecial, but don't specify what type of special paste. See the Microsoft (or this one) page for more info.
Please be patient as I try to explain the dilemma. I am trying to write a macro that will help me sort the following table:
and trying to sort by sales ID into another worksheet(within the same workbook) with these pre-formatted tables:
End result should look like below image where all I need to do is fill in the sales ID and the formulas to the right of the sales ID column calculate or perform lookups:
Problem is that my team has been filling the tables manually or using a combination of the sort function to fill in the tables manually. Problem is that this can be a pain when we have 10,000+ sales IDs and no automation. My attempt at coding this to help my team has not been helped by my limited vba knowledge - any assistance appreciated:
Edit: I made some modifications to Kelvin's code (thanks #kelvin!) and I want to clarify that all I want to do is paste special values those sales ID into my "Tables" tab based off of the positions of the pre-formatted table. See new image below as well as re-posed code. Note the formulas in my Tables tab without Sales IDs (my fault that I wasn't clear)
One last note: The last thing I am trying to solve to complete this is to scan two ranges and filter out the unique pairs into an array to make the array CFValues below dynamic - please help if you know how to do this better than me!
Option Explicit
Sub SortNCopy2TablesV2()
Dim CFValues As Variant
Dim r As Integer
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim CombStr As Variant
Const startRow As Long = 7 'kelvin added
CFValues = Array("P A", "P B", "P C", "P F", "M A", "SP A", "SP B", "SP C")
Set ws1 = Worksheets("Cashflow")
Set ws2 = Worksheets("Tables")
r = startRow 'kelvin changed
'kelvin added
Application.ScreenUpdating = False
On Error Resume Next
For i = LBound(CFValues) To UBound(CFValues)
Worksheets.Add
ActiveSheet.Name = CFValues(i)
If Err.Number = 1004 Then
Application.DisplayAlerts = False
Worksheets(CFValues(i)).Cells.Clear
ActiveSheet.Delete
Application.DisplayAlerts = True
End If
Next i
On Error GoTo 0
With ws1 'kelvin added
Do Until .Range("C" & r).Value = ""
CombStr = .Range("C" & r).Text + " " + .Range("D" & r).Text 'kelvin changed
For i = LBound(CFValues) To UBound(CFValues)
If StrComp(CombStr, CFValues(i), vbTextCompare) = 0 Then 'kelvin changed
'kelvin added 1 lines of code:
.Range("B" & r).Copy _
Worksheets(CFValues(i)).Range("B" & Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B")) + 1)
End If
Next i
r = r + 1
Loop
End With
'kelvin added
Dim nextRow As Long
Dim tempRow As Long
Dim numRows As Long
nextRow = 5
For i = LBound(CFValues) To UBound(CFValues)
tempRow = Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B"))
If tempRow > 0 Then
numRows = Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B"))
ws2.Range("B" & nextRow + 1).EntireRow.Resize(numRows).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ws2.Range("C" & nextRow & ":" & "F" & nextRow + numRows).FillDown
Worksheets(CFValues(i)).Range("B2").CurrentRegion.Copy ws2.Range("B" & nextRow + 1)
ws2.Range("B" & nextRow + 2 + tempRow) = CFValues(i)
nextRow = nextRow + tempRow + 5
End If
Next i
Application.ScreenUpdating = True
End Sub
According to your codes, the header of the first table starts at cell B6 and the first row of data starts at B7. Modifying your macros, I manage to do the sorting and place the result on the Tables sheet. However, I can't calculate the NPV for you because I don't know the exact formula. Please find the codes:
Option Explicit
Sub SortNCopy2TablesV2()
Dim CFValues As Variant
'Dim InsertRow As Variant
Dim R As Integer
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim CombStr As Variant
Const startRow As Long = 7 'kelvin added
CFValues = Array("P A", "P B", "P C", "P F", "M A", "SP A", "SP B", "SP C")
' InsertRow = Array(6, 11, 16, 21, 26, 31, 36, 41)
Set ws1 = Worksheets("Cashflow")
Set ws2 = Worksheets("Tables")
R = startRow 'kelvin changed
'kelvin added
Application.ScreenUpdating = False
On Error Resume Next
For i = LBound(CFValues) To UBound(CFValues)
Worksheets.Add
ActiveSheet.Name = CFValues(i)
If Err.Number = 1004 Then
Application.DisplayAlerts = False
Worksheets(CFValues(i)).Cells.Clear
ActiveSheet.Delete
Application.DisplayAlerts = True
End If
Next i
On Error GoTo 0
With ws1 'kelvin added
'org: Do Until ws1.Range("C" & R).Value = ""
Do Until .Range("C" & R).Value = ""
'org: CombStr = ws1.Range("C" & R).Text + "" + ws1.Range("D" & R).Text
CombStr = .Range("C" & R).Text + " " + .Range("D" & R).Text 'kelvin changed
For i = LBound(CFValues) To UBound(CFValues)
'org: If StrComp(CombStr, CFValues(i), vbTextCompare) Then
If StrComp(CombStr, CFValues(i), vbTextCompare) = 0 Then 'kelvin changed
'Return value of first insert row in InsertRow[] array -
' i.e. if P A, then it should return row 6 for insertion, if P B, then row 11, etc.
'insert new row, copying and pasting the formulas down and copying the sales ID
'Insert Sales ID value into Table tab
'org: ActiveCell.Offset(1, 0).EntireRow.Copy
'org: ActiveCell.Offset(2, 0).EntireRow.Insert Shift:=xlDown
'org: ActiveCell.Offset(2, 0).EntireRow.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
'org: Application.CutCopyMode = False
'org: ws1.Range("B" & R).Value = ws2.Range("B" & InsertRow(i) + 1).Value
'kelvin added 1 lines of code:
.Range("A" & R).EntireRow.Copy _
Worksheets(CFValues(i)).Range("A" & Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B")) + 1)
'decrement InsertRow[] array, so that the
'program always knows where to find the next tables for insertion
'Else
End If
Next i
R = R + 1
Loop
End With
'kelvin added
ws2.Cells.Clear
Dim nextRow As Long
Dim tempRow As Long
nextRow = startRow
For i = LBound(CFValues) To UBound(CFValues)
tempRow = Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B"))
If tempRow > 0 Then
ws1.Range("A" & startRow - 1).EntireRow.Copy ws2.Range("A" & nextRow - 1)
Worksheets(CFValues(i)).Range("B2").CurrentRegion.Copy ws2.Range("B" & nextRow)
ws2.Range("A" & nextRow + tempRow) = CFValues(i)
nextRow = nextRow + tempRow + 5
End If
Next i
Application.ScreenUpdating = True
End Sub
(Oops... I can't post Image. Please find the pasted text of input and output)
Sample Input:
Sale ID S Class B Class Balance Month Rate
1 P A 100 20 5
2 P A 200 25 4
3 P A 300 30 3
4 SP C 400 35 2
5 SP C 500 40 1
6 M C 600 45 2
7 M B 700 50 3
8 M B 800 55 4
9 P F 900 60 5
10 SP F 1000 55 6
11 M F 1100 50 7
12 M A 1200 45 8
13 Sp B 1300 40 9
14 Sp C 1400 35 10
Sample Output:
Sale ID S Class B Class Balance Month Rate
1 P A 100 20 5
2 P A 200 25 4
3 P A 300 30 3
P A
Sale ID S Class B Class Balance Month Rate
9 P F 900 60 5
P F
Sale ID S Class B Class Balance Month Rate
12 M A 1200 45 8
M A
Sale ID S Class B Class Balance Month Rate
13 Sp B 1300 40 9
SP B
Sale ID S Class B Class Balance Month Rate
4 SP C 400 35 2
5 SP C 500 40 1
14 Sp C 1400 35 10
SP C
Please comment. Thank you.
I saw you received an other answer while I wrote this code, but though I would post it anyway. The code below should be pasted to the vba part of the Tables sheet. You should then create a button on that sheet (in developer tab) and assign it to the macro StartSortClick
This code assumes the following, and it must be changed accordingly for what is not correct. If you comment below where my assumptions are wrong, I can update it for you, or you can do it yourself.
CashFlow tab has headings in row 1, with Sale ID in A1, Seller Class in B1, etc
In the tables tab, you want the first table to start at row 10, and in column A, so that Sale ID of the first table is written in A10.
I have not entered formulas for price and npv, provide your formulas if you wish me to.
Font is changable too. Just to it for the entire sheet at the end of the code (code will overwrite manual font change before code is run, to ensure table borders are placed properly).
I am sure it could have been done neater, and I think it could be slow with 10000+ rows but it does what you ask. Using 2-dimensional arrays would be quicker, I see now. Working on a version of that (because I need to get better at using arrays myself, and your problem was fun working on)
Public Sub StartSortClick()
If MsgBox("This will rebuild the Tables tab! Continue?", vbYesNo, "Rebuild Tables Tab?") Then
SortNCopyTables
End If
End Sub
Private Sub SortNCopyTables()
Application.ScreenUpdating = False
Dim sheetCollection As Collection
Set sheetCollection = New Collection
Dim cashFlowSheet As Worksheet
Set cashFlowSheet = Worksheets("CashFlow")
Dim SaleIDRange, BalanceRange, MonthlyRange, RateRange As Range 'Change the letters and starting rows as necessary
Set SaleIDRange = cashFlowSheet.Range("A2:A" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set BalanceRange = cashFlowSheet.Range("D2:D" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set MonthlyRange = cashFlowSheet.Range("E2:E" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row) ' not used now but assume is used for npv / price calcs
Set RateRange = cashFlowSheet.Range("F2:F" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
'loop through all rows, if encountering a new seller-bucket combo, create a new sheet, name it that seller-bucket combo and add it to the sheetCollection
Dim cRow As Long
cRow = 2 ' should be the location of first cashflow entry
Dim sellerBucketString As String
Dim tempSheet As Worksheet
Dim firstUnusedRow As Long
Do Until cashFlowSheet.Cells(cRow, 1) = "" ' here you should change the 1 to whatever column is your Sale ID column (mine are in A)
sellerBucketString = cashFlowSheet.Cells(cRow, 2).Value + " & " + cashFlowSheet.Cells(cRow, 3).Value
If Not InCollection(sheetCollection, sellerBucketString) Then
'create new sheet and add to collection
With ThisWorkbook
Set tempSheet = .Sheets.Add(After:=.Sheets(.Sheets.Count))
tempSheet.Name = sellerBucketString
sheetCollection.Add tempSheet, tempSheet.Name
End With
End If
' select worksheet and insert row at the bottom)
Set tempSheet = sheetCollection.Item(sellerBucketString)
firstUnusedRow = tempSheet.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).row
tempSheet.Cells(firstUnusedRow, 1).Value = cashFlowSheet.Cells(cRow, 1).Value
cRow = cRow + 1
Loop
'loop through sheets in the collection and create appropriate report tables in Tables sheet
Dim tablesSheet As Worksheet
Set tablesSheet = Worksheets("Tables")
'clear the tableSheet, just in case
tablesSheet.Rows(10 & ":" & tablesSheet.Rows.Count).Clear
Dim tRow As Long
tRow = 10 ' this is where I start to build my table
Dim row As Long
Dim tempSumRow As Range
Dim ws As Worksheet
For Each ws In sheetCollection
Dim tableStartRow As Long
tableStartRow = tRow + 1
With tablesSheet
.Cells(tRow, 1).Value = "Sale ID"
.Cells(tRow, 1).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 2).Value = "NPV"
.Cells(tRow, 2).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 3).Value = "Price"
.Cells(tRow, 3).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 4).Value = "Balance"
.Cells(tRow, 4).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 5).Value = "Rate"
.Cells(tRow, 5).Font.Underline = xlUnderlineStyleSingleAccounting
tRow = tRow + 1
For row = 2 To ws.Cells.SpecialCells(xlCellTypeLastCell).row
.Cells(tRow, 1).Value = ws.Cells(row, 1).Value
'.Cells(tRow, 2).Value = ??? NPV formula?
'.Cells(tRow, 3).Value = ??? price formula?
.Cells(tRow, 4).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
.Cells(tRow, 4).NumberFormat = "$#,##0.00"
.Cells(tRow, 5).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
.Cells(tRow, 5).NumberFormat = "0.0 %"
tRow = tRow + 1
Next row
' add summing row
.Cells(tRow, 1).Value = ws.Name
.Cells(tRow, 1).Font.Bold = True
.Cells(tRow, 2).Formula = "=SUM(B" + CStr(tableStartRow) + ":B" + CStr(tRow - 1) + ")"
.Cells(tRow, 3).Formula = "=AVERAGE(C" + CStr(tableStartRow) + ":C" + CStr(tRow - 1) + ")"
.Cells(tRow, 4).Formula = "=SUM(D" + CStr(tableStartRow) + ":D" + CStr(tRow - 1) + ")"
.Cells(tRow, 5).Formula = "=AVERAGE(E" + CStr(tableStartRow) + ":E" + CStr(tRow - 1) + ")"
Set tempSumRow = tablesSheet.Range("A" + CStr(tRow) + ":E" + CStr(tRow))
With tempSumRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With tempSumRow.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
'.Cells(
'create space for new table (this leaves one row of space, increase to 3 or more if you wish)
tRow = tRow + 2
End With
Next ws
tablesSheet.Cells.Font.Name = "Arial" ' change this to your appropriate font
DeleteAll
tablesSheet.Activate
Application.ScreenUpdating = True
End Sub
Private Function InCollection(col As Collection, sKey As String) As Boolean
Dim bTest As Boolean
On Error Resume Next
bTest = IsObject(col(sKey))
If (Err = 0) Then
InCollection = True
Else
Err.Clear
End If
End Function
Private Sub DeleteAll()
Dim i As Integer
i = Worksheets.Count
For x = i To 3 Step -1
Application.DisplayAlerts = False
Worksheets(x).Delete
Application.DisplayAlerts = True
Next x
End Sub
EDIT:
Ok. Redid code using arrays to store cell values prior to writing them to the tables sheet. It did slightly faster, 1 min 57 vs 2 min 22 for 15,000 rows. Here is the alternative code. Alter the button click to call this formula instead if you wish to use it. Note this code might be a bit more untidy, as I need to log off stackExchange now.
Private Sub SortNCopyTables2()
Application.ScreenUpdating = False
Dim saleIDs() As Variant
Dim sellerClass() As Variant
Dim bucketClass() As Variant
Dim cashFlowSheet As Worksheet
Set cashFlowSheet = Worksheets("CashFlow")
Dim lastSaleIDRow As Long
lastSaleIDRow = cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row
saleIDs = cashFlowSheet.Range("A2:A" & lastSaleIDRow).Value
sellerClass = cashFlowSheet.Range("B2:B" & lastSaleIDRow).Value
bucketClass = cashFlowSheet.Range("C2:C3" & lastSaleIDRow).Value
Dim classPairsArray() As Variant
Dim classPairs() As String
ReDim Preserve classPairs(0)
ReDim Preserve classPairsArray(0)
Dim size As Long
size = 0
Dim saleID As String
Dim tempArray() As String
For counter = 1 To UBound(saleIDs, 1)
sellerBucketString = sellerClass(counter, 1) + " & " + bucketClass(counter, 1)
If UBound(Filter(classPairs, sellerBucketString)) < 0 Then
ReDim Preserve classPairs(size)
classPairs(size) = sellerBucketString
ReDim Preserve classPairsArray(size)
ReDim Preserve tempArray(0)
tempArray(0) = sellerBucketString
classPairsArray(size) = tempArray
size = size + 1
End If
Dim position As Long
For i = 0 To UBound(classPairsArray)
tempArray = classPairsArray(i)
If sellerBucketString = tempArray(0) Then
tempArray = classPairsArray(i)
ReDim Preserve tempArray(UBound(tempArray) + 1)
tempArray(UBound(tempArray)) = saleIDs(counter, 1)
classPairsArray(i) = tempArray
Exit For
End If
Next i
Next counter
'loop through array and write to worksheet
Dim tablesSheet As Worksheet
Set tablesSheet = Worksheets("Tables")
'clear the tableSheet, just in case
tablesSheet.Rows(10 & ":" & tablesSheet.Rows.Count).Clear
Dim SaleIDRange, BalanceRange, MonthlyRange, RateRange As Range 'Change the letters and starting rows as necessary
Set SaleIDRange = cashFlowSheet.Range("A2:A" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set BalanceRange = cashFlowSheet.Range("D2:D" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set MonthlyRange = cashFlowSheet.Range("E2:E" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row) ' not used now but assume is used for npv / price calcs
Set RateRange = cashFlowSheet.Range("F2:F" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Dim tRow As Long
tRow = 10 ' this is where I start to build my table
Dim row As Long
Dim tempSumRow As Range
For i = 0 To UBound(classPairsArray)
Dim tableStartRow As Long
tableStartRow = tRow + 1
Dim tableSellerBucketGroup As String
Dim tableArray() As String
tableArray = classPairsArray(i)
With tablesSheet
.Cells(tRow, 1).Value = "Sale ID"
.Cells(tRow, 1).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 2).Value = "NPV"
.Cells(tRow, 2).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 3).Value = "Price"
.Cells(tRow, 3).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 4).Value = "Balance"
.Cells(tRow, 4).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 5).Value = "Rate"
.Cells(tRow, 5).Font.Underline = xlUnderlineStyleSingleAccounting
tRow = tRow + 1
For j = 1 To UBound(tableArray)
.Cells(tRow, 1).Value = tableArray(j)
'.Cells(tRow, 2).Value = ??? NPV formula?
'.Cells(tRow, 3).Value = ??? price formula?
.Cells(tRow, 4).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
.Cells(tRow, 4).NumberFormat = "$#,##0.00"
.Cells(tRow, 5).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
.Cells(tRow, 5).NumberFormat = "0.0 %"
tRow = tRow + 1
Next j
.Cells(tRow, 1).Value = tableArray(0)
.Cells(tRow, 1).Font.Bold = True
.Cells(tRow, 2).Formula = "=SUM(B" + CStr(tableStartRow) + ":B" + CStr(tRow - 1) + ")"
.Cells(tRow, 3).Formula = "=AVERAGE(C" + CStr(tableStartRow) + ":C" + CStr(tRow - 1) + ")"
.Cells(tRow, 4).Formula = "=SUM(D" + CStr(tableStartRow) + ":D" + CStr(tRow - 1) + ")"
.Cells(tRow, 5).Formula = "=AVERAGE(E" + CStr(tableStartRow) + ":E" + CStr(tRow - 1) + ")"
Set tempSumRow = tablesSheet.Range("A" + CStr(tRow) + ":E" + CStr(tRow))
With tempSumRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With tempSumRow.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
tRow = tRow + 2
End With
Next i
tablesSheet.Activate
Application.ScreenUpdating = True
End Sub
gudal has written a workable code to generate the tables. Please find the complete code with small changes to gudal's code and the samples of input and output.
The code:
Private Sub SortNCopyTables2()
Application.ScreenUpdating = False
Dim saleIDs() As Variant
Dim sellerClass() As Variant
Dim bucketClass() As Variant
Dim cashFlowSheet As Worksheet
Set cashFlowSheet = Worksheets("CashFlow")
Dim lastSaleIDRow As Long
lastSaleIDRow = cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row
saleIDs = cashFlowSheet.Range("A2:A" & lastSaleIDRow).Value
sellerClass = cashFlowSheet.Range("B2:B" & lastSaleIDRow).Value
bucketClass = cashFlowSheet.Range("C2:C3" & lastSaleIDRow).Value
Dim classPairsArray() As Variant
Dim classPairs() As String
ReDim Preserve classPairs(0)
ReDim Preserve classPairsArray(0)
Dim size As Long
size = 0
Dim saleID As String
Dim tempArray() As String
For counter = 1 To UBound(saleIDs, 1)
sellerBucketString = sellerClass(counter, 1) + " & " + bucketClass(counter, 1)
If UBound(Filter(classPairs, sellerBucketString)) < 0 Then
ReDim Preserve classPairs(size)
classPairs(size) = sellerBucketString
ReDim Preserve classPairsArray(size)
ReDim Preserve tempArray(0)
tempArray(0) = sellerBucketString
classPairsArray(size) = tempArray
size = size + 1
End If
Dim position As Long
For i = 0 To UBound(classPairsArray)
tempArray = classPairsArray(i)
If sellerBucketString = tempArray(0) Then
tempArray = classPairsArray(i)
ReDim Preserve tempArray(UBound(tempArray) + 1)
tempArray(UBound(tempArray)) = saleIDs(counter, 1)
classPairsArray(i) = tempArray
Exit For
End If
Next i
Next counter
'loop through array and write to worksheet
Dim tablesSheet As Worksheet
Set tablesSheet = Worksheets("Tables")
'clear the tableSheet, just in case
'org: tablesSheet.Rows(10 & ":" & tablesSheet.Rows.Count).Clear
tablesSheet.Cells.Clear 'kelvin edited
Dim SaleIDRange, BalanceRange, MonthlyRange, RateRange As Range 'Change the letters and starting rows as necessary
Set SaleIDRange = cashFlowSheet.Range("A2:A" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set BalanceRange = cashFlowSheet.Range("D2:D" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set MonthlyRange = cashFlowSheet.Range("E2:E" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row) ' not used now but assume is used for npv / price calcs
Set RateRange = cashFlowSheet.Range("F2:F" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Dim tRow As Long
tRow = 10 ' this is where I start to build my table
Dim row As Long
Dim tempSumRow As Range
For i = 0 To UBound(classPairsArray)
Dim tableStartRow As Long
tableStartRow = tRow + 1
Dim tableSellerBucketGroup As String
Dim tableArray() As String
tableArray = classPairsArray(i)
With tablesSheet
.Cells(tRow, 1).Value = "Sale ID"
.Cells(tRow, 1).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 2).Value = "NPV"
.Cells(tRow, 2).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 3).Value = "Price"
.Cells(tRow, 3).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 4).Value = "Balance"
.Cells(tRow, 4).Font.Underline = xlUnderlineStyleSingleAccounting
.Cells(tRow, 5).Value = "Rate"
.Cells(tRow, 5).Font.Underline = xlUnderlineStyleSingleAccounting
tRow = tRow + 1
For j = 1 To UBound(tableArray)
.Cells(tRow, 1).Value = tableArray(j)
'.Cells(tRow, 2).Value = ??? NPV formula?
'.Cells(tRow, 3).Value = ??? price formula?
'org: .Cells(tRow, 4).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
.Cells(tRow, 4).Formula = "=IFERROR(INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0)),)" 'kelvin edited
.Cells(tRow, 4).NumberFormat = "$ #,##0.00" 'kelvin edited
'org: .Cells(tRow, 5).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
.Cells(tRow, 5).Formula = "=IFERROR(INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0)),)" 'kelvin edited
.Cells(tRow, 5).NumberFormat = "0%" 'kelvin edited
.Cells(tRow, 2).Formula = "=IFERROR(NPV(RC[3],RC[2]),)" 'kelvin added.
.Cells(tRow, 2).NumberFormat = "$ #,##0.00" 'kelvin added.
.Cells(tRow, 3).Formula = "=IFERROR(RC[-1]/RC[1],)" 'kelvin added.
.Cells(tRow, 3).NumberFormat = "0%" 'kelvin added.
tRow = tRow + 1
Next j
.Cells(tRow, 1).Value = tableArray(0)
.Cells(tRow, 1).Font.Bold = True
.Cells(tRow, 2).Formula = "=SUM(B" + CStr(tableStartRow) + ":B" + CStr(tRow - 1) + ")"
'org: .Cells(tRow, 3).Formula = "=AVERAGE(C" + CStr(tableStartRow) + ":C" + CStr(tRow - 1) + ")"
.Cells(tRow, 3).Formula = "=IFERROR(RC[-1]/RC[1],)" 'kelvin added.
.Cells(tRow, 3).NumberFormat = "0%" 'kelvin added.
.Cells(tRow, 4).Formula = "=SUM(D" + CStr(tableStartRow) + ":D" + CStr(tRow - 1) + ")"
'org: .Cells(tRow, 5).Formula = "=AVERAGE(E" + CStr(tableStartRow) + ":E" + CStr(tRow - 1) + ")"
Set tempSumRow = tablesSheet.Range("A" + CStr(tRow) + ":E" + CStr(tRow))
With tempSumRow.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With tempSumRow.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
tRow = tRow + 2
End With
Next i
tablesSheet.Activate
Application.ScreenUpdating = True
End Sub
Sample input and sample output:
Thanks to gudal.
Sub NewPortName ()
If ThisWorkbook.Sheets("PAR Form").Cells(2, 7).Value = "RJ45" Then
ThisWorkbook.Sheets("PAR_import").Cells(16, 3).Value = "PCI-" + ThisWorkbook.Sheets("Equipment details").Cells(4, 4).Value + "-" + Left(ThisWorkbook.Sheets("PAR Form").Cells(2, 13), 7)
ElseIf ThisWorkbook.Sheets("PAR Form").Cells(2, 7).Value = "LC-LC" Then
ThisWorkbook.Sheets("PAR_import").Cells(16, 3).Value = "PFI-" + ThisWorkbook.Sheets("Equipment details").Cells(4, 4).Value + "-" + Left(ThisWorkbook.Sheets("PAR Form").Cells(2, 13), 10) + ":" + ThisWorkbook.Sheets("PAR Form").Cells(2, 36) + " to " + Left(ThisWorkbook.Sheets("PAR Form").Cells(2, 14), 10) + ":" + ThisWorkbook.Sheets("PAR Form").Cells(2, 38)
End If
If ThisWorkbook.Sheets("PAR Form").Cells(3, 7).Value = "RJ45" Then
ThisWorkbook.Sheets("PAR_import").Cells(17, 3).Value = "PCI-" + ThisWorkbook.Sheets("Equipment details").Cells(4, 4).Value + "-" + Left(ThisWorkbook.Sheets("PAR Form").Cells(3, 13), 7)
ElseIf ThisWorkbook.Sheets("PAR Form").Cells(3, 7).Value = "LC-LC" Then
ThisWorkbook.Sheets("PAR_import").Cells(17, 3).Value = "PFI-" + ThisWorkbook.Sheets("Equipment details").Cells(4, 4).Value + "-" + Left(ThisWorkbook.Sheets("PAR Form").Cells(3, 13), 10) + ":" + ThisWorkbook.Sheets("PAR Form").Cells(3, 36) + " to " + Left(ThisWorkbook.Sheets("PAR Form").Cells(3, 14), 10) + ":" + ThisWorkbook.Sheets("PAR Form").Cells(3, 38)
End If
End sub
I am currently modifying this line by line for individual cells due to the nature of the output over several ranges.
I am wondering if this can be simplified using Range, Two of the ranges in question out of 7 are (M2:M100) and (N2:N100)
I will need to repeat this code and change the cells individually over 700 times to reflect 700 individual cells if I can't make this abstract
Check it out,
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet, Esh As Worksheet
Dim Rws As Long, Rng As Range, c As Range, cr
Dim s1 As String, s2 As String, s3 As String
Set sh = Sheets("PAR Form")
Set ws = Sheets("PAR_import")
Set Esh = Sheets("Equipment details")
s1 = "RJ45"
s2 = "LC-LC"
s3 = Esh.Cells(4, 4).Value
With sh
Rws = .Cells(.Rows.Count, "G").End(xlUp).Row
Set Rng = .Range(.Cells(2, "G"), .Cells(Rws, "G"))
End With
For Each c In Rng.Cells
cr = c.Row
If c = s1 Then
ws.Cells(cr + 14, 3).Value = "PCI-" + s3 + "-" + Left(sh.Cells(cr, 13), 7)
ElseIf c = s2 Then
ws.Cells(cr + 14, 3).Value = "PFI-" + s3 + "-" + Left(sh.Cells(cr, 13), 10) + ":" + sh.Cells(cr, 36) + " to " + Left(sh.Cells(cr, 14), 10) + ":" + sh.Cells(cr, 38)
End If
Next c
End Sub
You could always try a loop along the lines of the below:
Sub ing()
For i = 2 To 100
Select Case ThisWorkbook.Sheets("PAR Form").Cells(i, 7).Value
Case "RJ45"
ThisWorkbook.Sheets("PAR_import").Cells(i + 14, 3).Value = "PCI-" + ThisWorkbook.Sheets("Equipment details").Cells(4, 4).Value + "-" + Left(ThisWorkbook.Sheets("PAR Form").Cells(i, 13), 7)
Case "LC-LC"
ThisWorkbook.Sheets("PAR_import").Cells(i + 14, 3).Value = "PFI-" + ThisWorkbook.Sheets("Equipment details").Cells(4, 4).Value + "-" + Left(ThisWorkbook.Sheets("PAR Form").Cells(i, 13), 10) + ":" + ThisWorkbook.Sheets("PAR Form").Cells(i, 36) + " to " + Left(ThisWorkbook.Sheets("PAR Form").Cells(i, 14), 10) + ":" + ThisWorkbook.Sheets("PAR Form").Cells(i, 38)
End Select
Next i
End Sub