I have a huge set of data (almost 12k rows). I want t search column A for a keyword (Ex: name") and then move its corresponding value from column B to a new sheet. I have this working but can't figure out how to make it recursive so it looks at all 12k entries in column A. Please help.
See script below that works, but needs to be recursive
Sub Test()
With Sheets("original")
If .Range("A24").Value = "Name " Then
Sheets("new").Range("A1").Value = .Range("B24").Value
End If
End With
End Sub
you can just loop through the range of cells and use offset to get the value in column B to place in the new worksheet. It doesn't need to be recursive
Sub Test()
Dim c As Range
Dim iRow As Long
iRow = 1
For Each c In Sheets("original").Range("A:A")
If c.Value = "Name " Then
Sheets("new").Cells(iRow, 1).Value = c.Offset(0, 1).Value
'move to the next row
iRow = iRow + 1
End If
Next c
End Sub
Here bis an example using standard 2-D arrays. A dictionary is another array based option. An AutoFilter or Advanced Filter removes the need for arrays and/or iteration through the rows.
Note that this does not loop through 'all the rows in column A'. It stops looping when there are no more values in column B that could be returned.
Sub Test2()
'
'https://stackoverflow.com/questions/55928149
'
Dim i As Long, arr As Variant, bees As Variant
With Worksheets("original")
'collect source values
arr = .Range(.Cells(7, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
'prepare target array
ReDim bees(1 To 1, 1 To 1)
'loop through source value array and retain column B based on condition
For i = LBound(arr, 1) To UBound(arr, 1)
'case insensitive comparison
If LCase(arr(i, 1)) = LCase("Name ") Then
'assign column B value to target array
bees(1, UBound(bees, 2)) = arr(i, 2)
'make room for next matching value
ReDim Preserve bees(1 To 1, 1 To UBound(bees, 2) + 1)
End If
Next i
'trim off the last unused element of the target array
ReDim Preserve bees(1 To 1, 1 To UBound(bees, 2) - 1)
End With
'add new worksheet at end of worksheets queue
With Worksheets.Add(after:=Worksheets(Worksheets.Count))
'rename new worksheet
.Name = "bees"
'put target array in new worksheet starting at A2
.Cells(2, "A").Resize(UBound(bees, 2), UBound(bees, 1)) = _
Application.Transpose(bees)
End With
End Sub
Related
I need to display two columns A and B listed in a combobox with unique values. So if two rows have the same A but not the same B, it is not a duplicate, both column need to be duplicate. I found a code that list one column (A) with unique values but I don't know how to add the column B.
There's a picture of my data and how I want to display it in my ComboBox.
Here's the code:
Private Sub UserForm_Initialize()
Dim Cell As Range
Dim col As Variant
Dim Descending As Boolean
Dim Entries As Collection
Dim Items As Variant
Dim index As Long
Dim j As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim row As Long
Dim Sorted As Boolean
Dim temp As Variant
Dim test As Variant
Dim Wks As Worksheet
Set Wks = ThisWorkbook.Worksheets("Sheet1")
Set RngBeg = Wks.Range("A3")
col = RngBeg.Column
Set RngEnd = Wks.Cells(Rows.Count, col).End(xlUp)
Set Entries = New Collection
ReDim Items(0)
For row = RngBeg.row To RngEnd.row
Set Cell = Wks.Cells(row, col)
On Error Resume Next
test = Entries(Cell.Text)
If Err = 5 Then
Entries.Add index, Cell.Text
Items(index) = Cell.Text
index = index + 1
ReDim Preserve Items(index)
End If
On Error GoTo 0
Next row
index = index - 1
Descending = False
ReDim Preserve Items(index)
Do
Sorted = True
For j = 0 To index - 1
If Descending Xor StrComp(Items(j), Items(j + 1), vbTextCompare) = 1 Then
temp = Items(j + 1)
Items(j + 1) = Items(j)
Items(j) = temp
Sorted = False
End If
Next j
index = index - 1
Loop Until Sorted Or index < 1
ComboBox1.List = Items
End Sub
Any clue? Thanks!
Try this code, please. It assumes that unique definition means pairs of values from the two columns, on the same row, to be unique:
Sub UnicTwoValInTwoColumns()
Dim sh As Worksheet, arr As Variant, arrFin As Variant, countD As Long
Dim lastRow As Long, i As Long, j As Long, k As Long, boolDupl As Boolean
Set sh = ActiveSheet 'use here your sheet
'supposing that last row in column A:A is the same in column B:B
'If not, the last row for B:B will be calculated and then the higher will be chosen:
lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
ReDim arrFin(1 To 2, 1 To lastRow) 'redim the final array for maximum possible number of elements
arr = sh.Range("A3:B" & lastRow).value 'pun in array the range to be analized
k = 1 'initialize the first array element number
For i = 1 To UBound(arr, 1) 'iterate between the array elements
boolDupl = False 'initialize the variable proving that the pair of data already in arrFin
For j = 1 To k 'iterate between the arrFin elements in order to check for duplicates
If arr(i, 1) & arr(i, 2) = arrFin(1, j) & arrFin(2, j) Then
boolDupl = True: Exit For 'if a duplicate is found the loop is exited
End If
Next j
If Not boolDupl Then 'load the arrFin only if a duplicate has not been found
arrFin(1, k) = arr(i, 1): arrFin(2, k) = arr(i, 2)
k = k + 1 'increment the (real) array number of elements
End If
Next
ReDim Preserve arrFin(1 To 2, 1 To k - 1) 'redim array at the real dimension (preserving values)
With Me.ComboBox1
.ColumnCount = 2 'be sure that combo has 2 columns to receive values
.List = WorksheetFunction.Transpose(arrFin) 'fill the combo with the array elements
End With
End Sub
You can paste the code in the form Initialize event, or let the Sub like it is, copy it in the form module and only call it from the event in discussion. I would suggest you to proceed in this las way. If you have (or will have) something else in the event, it would be simpler to identify a problem if it occurs, I think,
I have a workbook that contains several sheets of data that I have combined. I removed some unnecessary sheets and cells (that are colour filled) and removed blanks (code sample below). I now have one work sheet with dates as headers and item numbers (col length vary).
I need to condense this again. I need two columns, columns A and B, B for every item number pulled back from the sheet and the Col A needs to be the header name of the column the item number was pulled from. The amount of columns will extend over time as more dates are added.
I just don't know where to go from here... The script is basic 'and then' I have quality checked it and it works up to this point.
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Combined"
For i = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If i > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(i).Activate
ActiveSheet.UsedRange.Copy xRg
Next i
Sheets("Data").Delete
For Each ws In Worksheets
If ws.Name <> "Combined" Then
ws.Visible = xlSheetHidden
End If
Next ws
I then have a box pop up to delete specific coloured cells and end with this:
Columns("A:MK").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
I can copy column values over, after the above, to a new sheet but then adding header values based on the last cell in that column reaches my limitations of VBA.
I can't see that this has been asked and answered previously, any ideas?
Try this code
Sub Test()
Dim a, ws As Worksheet, sh As Worksheet, i As Long, j As Long, k As Long
Set ws = ThisWorkbook.Worksheets("Combined")
Set sh = ThisWorkbook.Worksheets("Condensed")
a = ws.Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)
For j = LBound(a, 2) To UBound(a, 2)
For i = 2 To UBound(a)
k = k + 1
b(k, 1) = a(1, j)
b(k, 2) = a(i, j)
Next i
Next j
With sh.Range("A1")
.Resize(1, 2).Value = Array("Header1", "Header2")
.Offset(1).Resize(k, UBound(b, 2)).Value = b
End With
End Sub
you could use Dictionary object
assuming you want to condense data in a worksheet named "Condensed" already in place
Sub Condense()
Dim cel As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Combined")
For Each cel In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
dict.Add cel.Value, .Range(cel.Offset(1), cel.End(xlDown)).Value
Next
End With
Dim key As Variant
With Worksheets("Condensed")
For Each key In dict.keys
With .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(dict(key)))
.Value = key
.Offset(, 1) = dict(key)
End With
Next
End With
End Sub
I have column A that has all existing categories, new categories are listed in column C. I'm trying to determine how to take these new categories, and add them to column "a" if they aren't already in column A. In the example the new categories in column C are added to column A even if there are already in column A. I would also need range("a1") in the if-then line to be a dynamic range since new categories will be added as the code runs. Some constructive criticism would be greatly appreciated as well to help me in the future.
Sub newcategory()
Dim newcatcount As Integer
Dim i As Integer
newcat = Range("c100000").End(xlUp).Row
For i = 1 To newcat
If Cells(i, 3).Value <> Range("a1") Then
Cells(i, 3).Select
Selection.copy
Range("a100000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Please give this a try...
Sub AddNewCategories()
Dim lrA As Long, lrC As Long, i As Long, j As Long
Dim x, y, z(), dict
lrA = Cells(Rows.Count, 1).End(xlUp).Row
lrC = Cells(Rows.Count, 3).End(xlUp).Row
'Array to hold the categories in column A starting from Row1, assuming the categories start from A1. If not, change it accordingly.
x = Range("A1:A" & lrA).Value
'Array to hold the new categories in column C starting from Row1, assuming the categories start from C1. If not, change it accordingly.
y = Range("C1:C" & lrC).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For i = 1 To UBound(y, 1)
If Not dict.exists(y(i, 1)) Then
dict.Item(y(i, 1)) = ""
j = j + 1
ReDim Preserve z(1 To j)
z(j) = y(i, 1)
End If
Next i
If j > 0 Then
Range("A" & lrA + 1).Resize(j).Value = Application.Transpose(z)
End If
Set dict = Nothing
End Sub
you could use excel built in RemoveDuplicates() function, as follows (mind the comments):
Option Explicit
Sub newcategory()
Dim newcat As Range
With Worksheets("Categories") ' change "Categories" to your actual sheeet name
Set newcat = .Range("C1", .Cells(.Rows.Count, 3).End(xlUp)) ' get the range of all nwe categories in reference sheet column C from row 1 down to last not empty one
.Cells(.Rows.Count, 1).End(xlUp).Resize(newcat.Rows.Count).Value = newcat.Value ' append new categories values below existing categories in column A
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo ' remove duplicates
End With
End Sub
I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.
I have a variable number of rows.
I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.
Example:
ColA ColB ColC ColD
Monday A,B,C Red Email
Output:
ColA ColB ColC ColD
Monday A Red Email
Monday B Red Email
Monday C Red Email
Have tried something like:
colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
Rows.Insert(i)
Next i
Try this, you can easily adjust it to your actual sheet name and column to split.
Sub splitByColB()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
Do While r.row > 1
ar = Split(r.value, ",")
If UBound(ar) >= 0 Then r.value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
You can also just do it in place by using a Do loop instead of a For loop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:
Dim workingRow As Long
workingRow = 2
With ActiveSheet
Do While Not IsEmpty(.Cells(workingRow, 2).Value)
Dim values() As String
values = Split(.Cells(workingRow, 2).Value, ",")
If UBound(values) > 0 Then
Dim colA As Variant, colC As Variant, colD As Variant
colA = .Cells(workingRow, 1).Value
colC = .Cells(workingRow, 3).Value
colD = .Cells(workingRow, 4).Value
For i = LBound(values) To UBound(values)
If i > 0 Then
.Rows(workingRow).Insert xlDown
End If
.Cells(workingRow, 1).Value = colA
.Cells(workingRow, 2).Value = values(i)
.Cells(workingRow, 3).Value = colC
.Cells(workingRow, 4).Value = colD
workingRow = workingRow + 1
Next
Else
workingRow = workingRow + 1
End If
Loop
End With
This will do what you want.
Option Explicit
Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim lastrow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet4").Copy After:=.Worksheets("Sheet4")
Set ws = ActiveSheet
End With
With ws
lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = lastrow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub
A formula solution is close to your requirement.
Cell G1 is the delimiter. In this case a comma.
Helper E1:=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H$1,"")))+1
You must fill the above formula one row more.
A8:=a1
Fill this formula to the right.
A9:=LOOKUP(ROW(1:1),$E:$E,A:A)&""
Fill this formula to the right and then down.
B9:=MID($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))+1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)+1))-FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))-1)&""
Fill down.
Bug:
Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.
Given #A.S.H.'s excellent and brief answer, the VBA function below might be a bit of an overkill, but it will hopefully be of some help to someone looking for a more "generic" solution. This method makes sure not to modify the cells to the left, to the right, or above the table of data, in case the table does not start in A1 or in case there is other data on the sheet besides the table. It also avoids copying and inserting entire rows, and it allows you to specify a separator other than a comma.
This function happens to have similarities to #ryguy72's procedure, but it does not rely on the clipboard.
Function SplitRows(ByRef dataRng As Range, ByVal splitCol As Long, ByVal splitSep As String, _
Optional ByVal idCol As Long = 0) As Boolean
SplitRows = True
Dim oldUpd As Variant: oldUpd = Application.ScreenUpdating
Dim oldCal As Variant: oldCal = Application.Calculation
On Error GoTo err_sub
'Modify application settings for the sake of speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Get the current number of data rows
Dim rowCount As Long: rowCount = dataRng.Rows.Count
'If an ID column is specified, use it to determine where the table ends by finding the first row
' with no data in that column
If idCol > 0 Then
With dataRng
rowCount = .Offset(, idCol - 1).Resize(, 1).End(xlDown).Row - .Row + 1
End With
End If
Dim splitArr() As String
Dim splitLb As Long, splitUb As Long, splitI As Long
Dim editedRowRng As Range
'Loop through the data rows to split them as needed
Dim r As Long: r = 0
Do While r < rowCount
r = r + 1
'Split the string in the specified column
splitArr = Split(dataRng.Cells(r, splitCol).Value & "", splitSep)
splitLb = LBound(splitArr)
splitUb = UBound(splitArr)
'If the string was not split into more than 1 item, skip this row
If splitUb <= splitLb Then GoTo splitRows_Continue
'Replace the unsplit string with the first item from the split
Set editedRowRng = dataRng.Resize(1).Offset(r - 1)
editedRowRng.Cells(1, splitCol).Value = splitArr(splitLb)
'Create the new rows
For splitI = splitLb + 1 To splitUb
editedRowRng.Offset(1).Insert 'Add a new blank row
Set editedRowRng = editedRowRng.Offset(1) 'Move down to the next row
editedRowRng.Offset(-1).Copy Destination:=editedRowRng 'Copy the preceding row to the new row
editedRowRng.Cells(1, splitCol).Value = splitArr(splitI) 'Place the next item from the split string
'Account for the new row in the counters
r = r + 1
rowCount = rowCount + 1
Next
splitRows_Continue:
Loop
exit_sub:
On Error Resume Next
'Resize the original data range to reflect the new, full data range
If rowCount <> dataRng.Rows.Count Then Set dataRng = dataRng.Resize(rowCount)
'Restore the application settings
If Application.ScreenUpdating <> oldUpd Then Application.ScreenUpdating = oldUpd
If Application.Calculation <> oldCal Then Application.Calculation = oldCal
Exit Function
err_sub:
SplitRows = False
Resume exit_sub
End Function
Function input and output
To use the above function, you would specify
the range containing the rows of data (excluding the header)
the (relative) number of the column within the range with the string to split
the separator in the string to split
the optional (relative) number of the "ID" column within the range (if a number >=1 is provided, the first row with no data in this column will be taken as the last row of data)
The range object passed in the first argument will be modified by the function to reflect the range of all the new data rows (including all inserted rows). The function returns True if no errors were encountered, and False otherwise.
Examples
For the range illustrated in the original question, the call would look like this:
SplitRows Range("A2:C2"), 2, ","
If the same table started in F5 instead of A1, and if the data in column G (i.e. the data that would fall in column B if the table started in A1) was separated by Alt-Enters instead of commas, the call would look like this:
SplitRows Range("F6:H6"), 2, vbLf
If the table contained the row header plus 10 rows of data (instead of 1), and if it started in F5 again, the call would look like this:
SplitRows Range("F6:H15"), 2, vbLf
If there was no certainty about the number of rows, but we knew that all the valid rows are contiguous and always have a value in column H (i.e. the 3rd column in the range), the call could look something like this:
SplitRows Range("F6:H1048576"), 2, vbLf, 3
In Excel 95 or lower, you would have to change "1048576" to "16384", and in Excel 97-2003, to "65536".
I am trying to get Excel data, which was mapped using a grid/matrix mapping into a de-normalized for so that i can enter the data into a database.
How do you copy data in a grid from one excel sheet to the other as follow illustrated below.
I was trying something like this... but as you can see, i am far off!
Sub NormaliseList(mySelection As Range)
Dim cell As Range
Dim i As Long
i = 1
For Each cell In mySelection
If cell <> "" Then
Sheets(2).Range("A" & i).Value = cell(cell.Row, 1).Value
Sheets(2).Range("B" & i).Value = cell.Value
Sheets(2).Range("C" & i).Value = cell(1, cell.Column).Value
i = i + 1
Next cell
End Sub
For Reference. I Updated my code..
Simply add the code, assign macro shortcut to the function
Select the range that contains the intersection data (not the row and column data)
Run macro (Beware, sheet 2 will have data added in normalised form)
If there are multiple headings that are needed i figured i would consolidate into one column then perform a "text to columns" after processing.
Sub NormaliseList()
' to run - assign macro shortcut to sub - Select Intersection data (not row and column headings and run)
Dim Rowname, ColumnName, IntValue As String
Dim x, cntr As Integer
Dim test As Boolean
cntr = 0
For x = 1 To Selection.Count
If Selection(x).Value <> "" Then
cntr = cntr + 1
Rowname = ActiveSheet.Cells(Selection.Cells(x).Row, Selection.Column - 1)
ColumnName = ActiveSheet.Cells(Selection.Row - 1, Selection.Cells(x).Column)
IntValue = Selection(x).Value
test = addrecord(Rowname, ColumnName, IntValue, cntr)
End If
Next x
End Sub
Function addrecord(vA, vB, vC As String, rec As Integer) As Boolean
'Make sure that you have a worksheet called "Sheet2"
Sheets("Sheet2").Cells(rec, 1) = vA
Sheets("Sheet2").Cells(rec, 2) = vB
Sheets("Sheet2").Cells(rec, 3) = vC
End Function
I've got two posts, with usable code and downloadable workbook, on doing this in Excel/VBA on my blog:
http://yoursumbuddy.com/data-normalizer
http://yoursumbuddy.com/data-normalizer-the-sql/
Here's the code:
'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.
Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)
Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If
'You have the range to be normalized and the count of leftmost rows to be repeated.
'This section uses those arguments to set the two ranges to parse
'and the two corresponding arrays to fill
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With
'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
ListIndex = ListIndex + 1
For j = 1 To RepeatingColsCount
RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
Next j
Next i
'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
For j = 1 To RepeatingColsCount
If RepeatingList(i, j) = "" Then
RepeatingList(i, j) = RepeatingList(i - 1, j)
End If
Next j
Next i
'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
Next j
Next i
End With
'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(after:=.Item(.Count))
End With
End If
With wsTarget
'Put the data from the two arrays in the new worksheet.
.Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
.Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList
'At this point there will be repeated header rows, so delete all but one.
.Range("1:" & NormalizingColsCount - 1).EntireRow.Delete
'Add the headers for the new label column and the data column.
.Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
.Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub
You’d call it like this:
Sub TestIt()
NormalizeList ActiveSheet.UsedRange, 1, "Name", "Count", False
End Sub