Alternatives to looping through range twice - excel

Question

I am using a macro to re-organise 4600 lines of data into a more efficient layout. Currently, i have a macro but it misses data or puts data in the wrong place.
From the old data, the column A is notification number, column FO is sheet number and GB is zone number. Whilst column C is the data that is wanting to be inputted. So currently (as the photo shows, the data is very unorganisedand unreadable.
In the outputted sheet, the notification number is put in Row 1 in columns F on wards (No duplicates). In Column B and C is zone and sheet number respectively (No duplicates). Then, using the old data, plot Column C values in the correct column(Depending on notification number) and the correct row (depending on zone and sheet number).
I have achieved half of this, but not all values are not be inputted correctly.
I currently use range.find to see if the zone number exists, and if it doesn't add the zone value and sheet number into the last used row. However, if the zone number is found but the corresponding sheet number is different, then add these values and then also add the values from column C. However, if the correct cell is filled, find the next available cell in column that is empty and input value.
But, I cant find a better way to check these values than using range.find but i feel it is missing values and not comparing both values correctly.
Sub GenerateTable()
Application.ScreenUpdating = False
Dim RawDataWsNotificationRng, ModifiedDataWsNotificationRng As Variant
Dim cell As Range
Dim RawDataWsNotificationlrow, ModifiedDataWsNotificationlcolnum, ModifiedDataWsZoneLrow As Long
Dim ModifiedDataWsNotificationlcol As String
Dim serverfilename, DataSheetName, Newsheetname As String
Dim wkbk1, wkbk2 As Workbook
Dim RawDataWs, ModifiedDataWs As Worksheet
Dim FindNotificationNumber As Variant
serverfilename = InputBox("Please input name of dummy workbook (file must be open, include .xlsx")
If serverfilename = "" Then Exit Sub
Set wb1 = ThisWorkbook
Set wb2 = Workbooks(serverfilename)
DataSheetName = InputBox("Please enter name of sheet where data is stored")
If DataSheetName = "" Then Exit Sub
Set RawDataWs = wb2.Sheets(DataSheetName)
Set ModifiedDataWs = Sheets.Add(After:=Sheets(Sheets.Count))
Newsheetname = InputBox("Please enter name of new sheet")
ModifiedDataWs.Name = Newsheetname
RawDataWsNotificationlrow = RawDataWs.Range("A" & Rows.Count).End(xlUp).Row
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
ModifiedDataWsNotificationlcolnum = ModifiedDataWs.Cells(1, Columns.Count).End(xlToLeft).Column + 1
ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)
Set RawDataWsNotificationRng = RawDataWs.Range("A2:A" & RawDataWsNotificationlrow)
Set ModifiedDataWsNotificationRng = ModifiedDataWs.Range("F1:" & ModifiedDataWsNotificationlcol & "1")
'------------------------------------TableFeatures---------------------------------------------
With ModifiedDataWs
.Cells(1, "A").Value = "Feature Code"
.Cells(1, "B").Value = "Zone"
.Cells(1, "C").Value = "Sheet"
.Cells(1, "D").Value = "Feature Description"
.Cells(1, "E").Value = "'-TEN OGV KH73126 tolerance"
.Cells(1, "F").Value = "'-TEN OGV KH73126 tolerance"
.Cells(2, "E").Value = "Nominal"
.Cells(2, "F").Value = "Tolerance"
'------------------------------------NotificationColumns---------------------------------------------
For Each cell In RawDataWsNotificationRng
Set ModifiedDataWsNotificationRng = .Range("G1:" & ModifiedDataWsNotificationlcol & "1")
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)
If FindNotificationNumber Is Nothing Then
ModifiedDataWsNotificationlcolnum = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)
Cells(1, ModifiedDataWsNotificationlcol).Value = cell.Value
End If
Next cell
'------------------------------------ZoneandSheetValues---------------------------------------------
Dim RawDataWsZoneRng As Variant: Set RawDataWsZoneRng = RawDataWs.Range("GB2:GB" & RawDataWsNotificationlrow)
Dim ModifiedDataWsZoneRng As Variant: Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B:B")
Dim ModifiedDataWssheetRng As Variant: Set ModifiedDataWssheetRng = ModifiedDataWs.Range("C:C")
Dim RawDataWsExtentRng As Variant: Set RawDataWsExtentRng = RawDataWs.Range("C2:C" & RawDataWsNotificationlrow)
Dim cel As Range
Dim ColumnLetterLRow, LR As Long, ColumnLetter As String, FindSheetinModifiedWs As Variant
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
For Each cell In RawDataWsZoneRng
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)
Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(what:=cell.Value, lookat:=xlWhole)
Set FindSheetinModifiedWs = ModifiedDataWssheetRng.Find(what:=RawDataWs.Cells(cell.Row, "FO"), lookat:=xlWhole)
If RawDataWs.Cells(cell.Row, "H").Value = "CONACC" Then
If FindZoneInModifiedWs Is Nothing Then
LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
Else
If Not FindZoneInModifiedWs Is Nothing And FindSheetinModifiedWs Is Nothing Then
LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
Else
If cell.Value <> vbNullString Then
ColumnLetter = Split(Cells(1, FindNotificationNumber.Column).Address, "$")(1)
If (.Cells(FindZoneInModifiedWs.Row, ColumnLetter) = vbNullString) Then
ColumnLetterLRow = FindZoneInModifiedWs.Row
Else
Set ColumnLetterRow = .Range(ColumnLetter & FindZoneInModifiedWs.Row & ":" & ColumnLetter & "30000").Find(what:="", lookat:=xlWhole)
ColumnLetterLRow = ColumnLetterRow.Row
End If
.Cells(ColumnLetterLRow, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(ColumnLetterLRow, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(ColumnLetterLRow, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
End If
End If
End If
End If
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
Next cell
'--------------------------Loop through zones and find input all values for zones-----------------
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B3:B" & ModifiedDataWsZoneLrow)
Dim nextrow As Long
For Each cell In ModifiedDataWsZoneRng
For Each cel In RawDataWsZoneRng
If cel.Value = cell.Value Then
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(What:=RawDataWs.Cells(cel.Row, "A"), lookat:=xlWhole)
Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(What:=cell.Value, lookat:=xlWhole)
If IsEmpty(.Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value) = True Then
.Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value = RawDataWs.Cells(cel.Row, "C").Value
.Cells(FindZoneInModifiedWs.Row, "B").Value = RawDataWs.Cells(cel.Row, "GB").Value
.Cells(FindZoneInModifiedWs.Row, "C").Value = RawDataWs.Cells(cel.Row, "FO").Value
Else
End If
End If
Next cel
Next cell
any ideas would be greatly appreciated! sorry i am new to VBA!
Old Data Sheet
New Sheet
Link to workbook
Link to workbook

Answer 1

Well, that more more complex than i'd thought but here goes:
'type to manage data we use from each row
Type dataRow
notif As Variant
variable As Variant
sht As Variant
zone As Variant
End Type
Sub DoPivot()
Const SEP As String = "<>"
Dim rngData As Range, data, r As Long
Dim colDict As Object, rowDict As Object, comboDict As Object
Dim rd As dataRow, rngOutput As Range, col As Long, rw As Long, k
Dim k2, arr, dictCounts As Object
Dim wsOut As Worksheet, num As Long
Set colDict = CreateObject("scripting.dictionary")
Set rowDict = CreateObject("scripting.dictionary")
Set comboDict = CreateObject("scripting.dictionary")
Set dictCounts = CreateObject("scripting.dictionary")
data = Sheet9.Range("A2:D4788").Value 'source data
Set rngOutput = Sheet9.Range("H1") 'top-left cell for output
Set wsOut = rngOutput.Parent
rngOutput.Resize(5000, 5000).ClearContents
rngOutput.Resize(1, 2).Value = Array("Sheet", "Zone")
col = rngOutput.Column + 2 'start for notification# headers
rw = rngOutput.row + 1
'first pass - assess data variables
For r = 1 To UBound(data, 1)
rd = rowData(data, r)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) 'tracking how many unique combinations of these
comboDict(k) = comboDict(k) + 1 'increment count
'manage column header positions for unique notification numbers
If Not colDict.exists(rd.notif) Then
colDict.Add rd.notif, col 'store the column
rngOutput.EntireRow.Cells(1, col).Value = rd.notif 'add the header
col = col + 1
End If
Next r
'figure out # of rows for each sheet-Zone pair
For Each k In comboDict.keys
arr = Split(k, SEP)
k2 = Join(Array(arr(0), arr(1)), SEP) 'sheet<>zone
'is this more rows than any previous same k2 value?
dictCounts(k2) = Application.Max(dictCounts(k2), comboDict(k))
Next k
'create the row headers
For Each k In dictCounts.keys
num = dictCounts(k)
rowDict(k) = rw 'record start row for each sheet<>zone combo
wsOut.Cells(rw, rngOutput.Column).Resize(num, 2).Value = Split(k, SEP)
dictCounts(k) = 0 'reset so we can track while adding data
rowDict(k) = rw
rw = rw + num
Next k
'last pass - populate the data based on the dictionaries
For r = 1 To UBound(data, 1)
rd = rowData(data, r)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) '3-field combo
k2 = Join(Array(rd.sht, rd.zone), SEP) 'row key
wsOut.Cells(rowDict(k2) + (dictCounts(k)), _
colDict(rd.notif)).Value = rd.variable
dictCounts(k) = dictCounts(k) + 1 'increment this unique combo
Next r
End Sub
'populate a Type instance for a given row
Function rowData(data, r As Long) As dataRow
Dim rv As dataRow
rv.notif = IfEmpty(data(r, 1))
rv.variable = IfEmpty(data(r, 2))
rv.sht = IfEmpty(data(r, 3))
rv.zone = IfEmpty(data(r, 4))
rowData = rv
End Function
'substitute EMPTY for zero-length value
Function IfEmpty(v)
IfEmpty = IIf(Len(v) = 0, "EMPTY", v)
End Function
EDIT: if you want to filter out certain rows then you need to modify the loops which iterate over data
For r = 1 To UBound(data, 1)
If data(r, colHere) <> "X" Then '<< add your filter here
rd = rowData(data, r)
'rest of code as before...
End If
Next r