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 have a very little experience with VBA, and I would really appreciate any help with this issue.
I need to convert rows into columns from sheet 1 to sheet 2.
Input File
Desired Output
Sample data
My Code
Sub TransposeSpecial()
Dim lMaxRows As Long 'max rows in the sheet
Dim lThisRow As Long 'row being processed
Dim iMaxCol As Integer 'max used column in the row being processed
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
lThisRow = 2 'start from row 2
Do While lThisRow <= lMaxRows
iMaxCol = Cells(lThisRow, Columns.Count).End(xlToLeft).Column
If (iMaxCol > 1) Then
Rows(lThisRow + 1 & ":" & lThisRow + iMaxCol - 1).Insert
Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Copy
Range("C" & lThisRow + 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Clear
lThisRow = lThisRow + iMaxCol - 1
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
End If
lThisRow = lThisRow + 1
Loop
End Sub
Output obtained by Code
Desired output
Here you go, I made this flexible code. Just update the variables in the beginning.
Sub Transpose_my_cells()
Dim rng As Range
Dim sheet1, sheet2, addr As String
Dim src_top_row, src_left_col, dst_top_row, dst_left_col, data_cols, y As Integer
Application.ScreenUpdating = False
sheet1 = "Sheet1" 'Put your source sheet name here
sheet2 = "Sheet2" 'Put your destiny sheet name here
src_top_row = 1 'Put the top row number of the source here
src_left_col = 1 'Put the left col number of the source here
dst_top_row = 1 'Put the top row number of the destiny here
dst_left_col = 1 'Put the left col number of the destiny here
'Count data columns
data_cols = 0
Do Until Worksheets(sheet1).Cells(src_top_row, src_left_col + data_cols + 1) = ""
data_cols = data_cols + 1
Loop
'start copying data
With Worksheets(sheet1)
'first header
.Cells(src_top_row, src_left_col).Copy
addr = Cells(dst_top_row, dst_left_col).Address
Worksheets(sheet2).Range(addr).PasteSpecial
y = 0
'loop for each source row
Do Until .Cells(src_top_row + y + 1, src_left_col) = ""
'Create First column repetitions
.Cells(src_top_row + y + 1, src_left_col).Copy
addr = Cells(dst_top_row + y * data_cols + 1, dst_left_col).Address & ":" & Cells(dst_top_row + y * data_cols + data_cols, dst_left_col).Address
Worksheets(sheet2).Range(addr).PasteSpecial
'Transpose Data Headers
addr = Cells(src_top_row, src_left_col + 1).Address & ":" & Cells(src_top_row, src_left_col + data_cols).Address
.Range(addr).Copy
Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 1).PasteSpecial Transpose:=True
'Transpose Data columns
Set rng = Cells(src_top_row + y + 1, src_left_col + 1)
addr = rng.Address & ":" & rng.Offset(0, data_cols - 1).Address
.Range(addr).Copy
Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 2).PasteSpecial Transpose:=True
y = y + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Using VBA:
Sub Transpose_my_cells()
Worksheets("Sheet1").Range("A1:E1").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial Transpose:=True
End Sub
Notes:
Change Sheet1 and Sheet2 with your sheet names as shown in the VBA sheet list.
change A1:E1 to the source cell range
change A1 to the destiny top cell
There is probably a much easier/cleaner way to do this but it works. The way it's written now, it will take the data in Sheet1 and output the transposed data on Sheet2. It should work as long as your data starts in cell A1.
Option Explicit
Sub transpose()
Dim names() As String
Dim count As Long
Dim i As Long
Dim j As Long
Dim rng As Range
Dim tmp As Long
Sheets("Sheet1").Activate
count = 0
With ThisWorkbook.Sheets("Sheet1")
Do Until .Cells(1, 2 + count) = ""
count = count + 1
Loop
ReDim names(0 To count - 1)
count = 0
Do Until .Cells(1, 2 + count) = ""
names(count) = .Cells(1, 2 + count).Value
count = count + 1
Loop
.Range("A2").Activate
Set rng = Range(Selection, Selection.End(xlDown))
End With
j = 0
With ThisWorkbook.Sheets("Sheet2")
.Cells(1, 1).Value = "ID"
.Cells(1, 2).Value = "Name"
.Cells(1, 3).Value = "Value"
For i = 0 To rng.count * count - 1
If i Mod count = 0 Then
j = j + 1
Range(Cells(j + 1, 2), Cells(j + 1, count + 1)).Copy
.Cells(i + 2, 3).PasteSpecial transpose:=True
End If
.Cells(i + 2, 1).Value = rng(j).Value
.Cells(i + 2, 2).Value = names(i Mod count)
Next i
.Activate
End With
End Sub
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.