I have a script that forms arrays within an overarching array based on duplicate values in column A.
manager 1 its own workbook
manager 2
manager 2 these two would be grouped into another workbook and so on.
problem is, these cells in column A are now transposed as headers in row 1.
How would I edit this script to now group this data by the row headers and take the whole column instead of how the script is originally written?
I figure it has something to do with swapping the Last = Data(1,i) or something like that.
Option Explicit
Sub Main()
Dim wb As Workbook
Dim Data, Last, JobFamily
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set wb = Workbooks("Book2.xlsx")
'Refer to the destination cell
Set Dest = wb.Sheets("Sheet11").Range("B1")
'Read in all data
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("bj2", .Range("A" & Rows.Count).End(xlUp))
End With
wb.Activate
Application.ScreenUpdating = False
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & ".xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 1 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
'Next column
j = j + 1
Next
End Sub
You called it. All references to "Data(i,1)" must be replaced with "Data(1,i)" to transpose the first column of the range into the first row.
Related
I have several workbooks with multiple worksheets. Each worksheet has two columns in positions "H" and "I". These columns in each worksheet has a different number of rows for these two columns. The worksheets are named differently as in
Sheet1: Data
Sheet2: Calc
Sheet3: Settings
Sheet4: Append1
Sheet5: Append2
.....
After the "Settings" sheet, each sheet is named append and then 1,2,3,...
I want to copy the columns H and I from every sheet except Calc and Settings into a new sheet.
It should be copied as columns. So it should look something like this in the new sheet
Data.col(H)|Data.col(I)|Append1.col(H)|Append1.col(I)|Append2.col(H)|Append2.col(I)| .....
How do I achieve this?
I have been using the formula =Append1H:H and =Append1I: I but it is too much data and cannot be done manually.
Any help is appreciated.
Please, try the next way. It will be very fast, using arrays and working mostly in memory. It does not use clipboard, it will not copy the range format. It will return in columns "A:B" of the newly created sheet (or the cleaned one, if already existing):
Sub copyColumns()
Dim wb As Workbook, ws As Worksheet, lastR As Long, arrC, arrFin, i As Long
Set wb = ActiveWorkbook 'use here the apropriate workbook
For Each ws In wb.Worksheets
If ws.name <> "Settings" And ws.name <> "Calc" And _
ws.name <> "Cons_Sheet" Then
i = i + 1
lastR = ws.Range("H" & ws.rows.count).End(xlUp).row
arrC = ws.Range("H" & IIf(i = 1, 1, 2) & ":I" & lastR).value 'copy header only from the first sheet
arrFin = buildArr(arrFin, arrC, i) 'add arrC to the one keeping all processing result
End If
Next ws
'add a new sheet, or clean it if existing:
Dim shC As Worksheet
On Error Resume Next
Set shC = wb.Worksheets("Cons_Sheet")
On Error GoTo 0
If Not shC Is Nothing Then
shC.UsedRange.ClearContents
Else
Set shC = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.count))
shC.name = "Cons_Sheet"
End If
'drop the processed array content in the new added sheet:
shC.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
MsgBox "Ready..."
End Sub
Function buildArr(arrF, arrC, i As Long) As Variant
If i = 1 Then arrF = arrC: buildArr = arrF: Exit Function 'use the first returned array
Dim arrSum, j As Long, k As Long
arrSum = WorksheetFunction.Transpose(arrF)
ReDim Preserve arrSum(1 To UBound(arrF, 2), 1 To UBound(arrF) + UBound(arrC))
k = UBound(arrF)
For i = 1 To UBound(arrC)
k = k + 1
For j = 1 To UBound(arrC, 2)
arrSum(j, k) = arrC(i, j)
Next j
Next i
buildArr = WorksheetFunction.Transpose(arrSum)
End Function
You can Just use this formula.
I choose 3 different range in the formula just to show you, you can use any kind of range for this to work.
=FILTERXML(""&SUBSTITUTE(TEXTJOIN(",",TRUE,Table1[Fruits Name],Sheet3!E2:E128,Sheet4!A2:A73),",","")&"","//y")
I'll just provide snippets. Basically I have two sets of data on a master roster, and they're divided by an X value in column H of the roster. I want X's to be printed to Sheet1 of Wb and Blanks to be printed to Sheet2.
I have it working, but since it declares FinalDest as a singular variable, it doesn't start on row 2 of the Sheet2.
Example: if X's fill to row 10 of Sheet1, it will start Sheet2's data on row 11 instead of 2 (after headers).
Sub Main()
Dim Wb As Workbook
Dim Data, Last, Login, SaveTyping
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest1 As Range, Dest2 As Range, FinalDest As Range
Set Wb = Workbooks("Template.xlsx")
Set Dest1 = Wb.Sheets("Currently Eligible").Range("A2")
Set Dest2 = Wb.Sheets("Newly Eligible").Range("A2")
With ThisWorkbook.Sheets("Roster")
Data = .Range("AA2", .Range("A" & Rows.Count).End(xlUp))
End With
After I declare my array, this is how I separate what's printed to the template.
SaveTyping = Data(i, 8) 'Column my X's and Blanks are
If InStr(SaveTyping, "X") Then
Set FinalDest = Dest1
End If
If SaveTyping = "" Then
Set FinalDest = Dest2
End If
For k = 1 To UBound(Data, 2)
FinalDest.Offset(j, a) = Data(i, k) 'Where I need to tell array to print
a = a + 1
Next
j = j + 1
Next
FinalDest range picks up on the next row after where it left off from Sheet1, how do I prevent that and have it start on Row 2 for both sheets?
Option Explicit
Sub Main()
Dim Wb As Workbook 'Workbook I'm printing each managers employee roster to and saving off a copy to a folder
Dim Data, Last, Login, chkVal 'Data = data I'm printing into template / Last = Manager name / Login = Manager Login ID
Dim i As Long, j As Long, k As Long, a As Long 'i = Data(row) / k = Data(column) / a = Wb(row) / j = Wb(column)
Dim Dest1 As Range, Dest2 As Range, FinalDest As Range 'Dest1 = Sheets(1) of Wb / Dest2 = Sheets(2) of Wb
Set Wb = Workbooks("Template.xlsx") 'Sets template for each file cut
Set Dest1 = Wb.Sheets("Currently Eligible").Range("B2")
Set Dest2 = Wb.Sheets("Newly Eligible").Range("B2")
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("AA2", .Range("A" & Rows.Count).End(xlUp)) 'Raw data
End With
Wb.Activate
Application.ScreenUpdating = False
For i = 1 To UBound(Data) 'Row 1 to Ubound of Data(rows)
If Data(i, 1) <> Last Then 'only print array to Wb one manager at a time, we see when managers change because values in Data(i,1) will <> the next cell
If i > 1 Then 'skip header
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Login & " - " & Last & " - Shift Differential Validation.xlsx")
End If
With Sheets("Exempt Population")
.Rows(2 & ":" & .Rows.Count).ClearContents 'Clears previous managers data
End With
Last = Data(i, 1) 'Manager last name is in Column A
chkVal = Data(i, 8) 'Check for X or Blank in Column H
Login = Data(i, 27) 'Manager login ID is in column AA
j = 0 'Wb Column = 0
End If
a = 0 'Wb Row = 0
SaveTyping = Data(i, 8) 'Column my X's and Blanks are
If InStr(SaveTyping, "X") Then
Set FinalDest = Dest1
End If
If SaveTyping = "" Then
Set FinalDest = Dest2
End If
For k = 1 To UBound(Data, 2) 'Column 1 to Ubound of Data(columns)
FinalDest.Offset(j, a) = Data(i, k)
a = a + 1 'next Wb row
Next
j = j + 1 'next Wb column
Next
SaveCopy Wb, Login, Last '<< save the last report
End Sub
I cleaned up the code a bit, giving proper names to indexes.
In terms of a solution to your issue, I added two different row indices, one for X one for blank. Depending on whether its an X or blank, you increment either the one or the other.
Option Explicit
Sub Main()
Dim Wb As Workbook 'Workbook I'm printing each managers employee roster to and saving off a copy to a folder
Dim Data, Last, Login, chkVal 'Data = data I'm printing into template / Last = Manager name / Login = Manager Login ID
Dim row_data As Long, col_wb As Long, col_data As Long, row_wb As Long
Dim Dest1 As Range, Dest2 As Range, FinalDest As Range 'Dest1 = Sheets(1) of Wb / Dest2 = Sheets(2) of Wb
Dim row_index_x As Long, row_index_blank As Long, isX As Long
Set Wb = Workbooks("Template.xlsx") 'Sets template for each file cut
Set Dest1 = Wb.Sheets("Currently Eligible").Range("B2")
Set Dest2 = Wb.Sheets("Newly Eligible").Range("B2")
With ThisWorkbook.Sheets("Sheet1")
Data = .Range("AA2", .Range("A" & Rows.Count).End(xlUp)) 'Raw data
End With
Wb.Activate
Application.ScreenUpdating = False
' initialise row indices to 0, ignore header as Dest1 and Dest2 already at B2.
row_index_x = 0
row_index_blank = 0
For row_data = 1 To UBound(Data) 'Row 1 to Ubound of Data(rows)
' if manager name changed between this row and previous row
If Data(row_data, 1) <> Last Then 'only print array to Wb one manager at a time, we see when managers change because values in Data(row_data,1) will <> the next cell
If row_data > 1 Then 'skip header
' save wb every time manager changes
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Login & " - " & Last & " - Shift Differential Validation.xlsx")
End If
With Sheets("Exempt Population")
.Rows(2 & ":" & .Rows.Count).ClearContents 'Clears previous managers data
End With
Last = Data(row_data, 1) 'Manager last name is in Column A
chkVal = Data(row_data, 8) 'Check for X or Blank in Column H
Login = Data(row_data, 27) 'Manager login ID is in column AA
' reset output row every time manager name changes
row_wb = 0 'Wb Row = 0
End If
' for every data row, reset output column to zero (start a new row)
col_wb = 0 'Wb Col = 0
SaveTyping = Data(row_data, 8) 'Column my X's and Blanks are
' decide output destination
If InStr(SaveTyping, "X") Then
Set FinalDest = Dest1
row_wb = row_index_x
isX = 1 ' remember whether its X or blank
End If
If SaveTyping = "" Then
Set FinalDest = Dest2
row_wb = row_index_blank
isX = 0
End If
' Loop through all columns for one row of data
' keep output row the same, increase the output column
For col_data = 1 To UBound(Data, 2) 'Column 1 to Ubound of Data(columns)
FinalDest.Offset(row_wb, col_wb) = Data(row_data, col_data)
col_wb = col_wb + 1 'next Wb column
Next
'row_wb = row_wb + 1 'next Wb row
' decide which row index to increase
If isX = 1 Then
row_index_x = row_index_x + 1
Else
row_index_blank = row_index_blank + 1
End If
Next
SaveCopy Wb, Login, Last '<< save the last report
End Sub
I have a script that processes a master file and creates a report per manager. In column A, all rows under mgr 1 are stored and printed to a template, and then it loops through all managers until the data ends.
Option Explicit
Sub Main()
Dim Wb As Workbook
Dim Data, Last
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set Wb = Workbooks("SpecializedSkillsTemplate.xlsx")
'Refer to the destination cell
Set Dest = Wb.Sheets("Manager Summary").Range("B1")
'Read in all data
With ThisWorkbook.Sheets("Sheet7")
Data = .Range("Z2", .Range("A" & Rows.Count).End(xlUp))
End With
Wb.Activate
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & "_Assessment.xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
'Next column
j = j + 1
Next
End Sub
It takes the data from sheet 7 in the master file, but is it possible to have another For/Next loop that does this for another sheet? Say I have sheet 8 and I want it to do the same thing and take that employee data and transpose offset it by a column, so I can compare the two sets. Is this possible?
I was thinking of adding something like:
Dim Data2
With ThisWorkbook.Sheets("Sheet8")
Data2 = .Range("Z2, . Range("A" & Rows.Count).End(xlUp))
End With
and then another For/Next Loop:
For x = 1 to UBound(Data2)
If Data2(I,1) <> Last
Next
etc. Can anyone let me know if this is feasible?
Variantly Integrating For Next Loop
The Tasks
I've added 6 lines and modified one (marked with '*** in the code.
Added string constant that will hold sheet names.
Added variant where the sheet names will be put into and read from.
Added counter for looping through sheet names in variant.
Using the split function pasted data from string into variant (array).
Started For Next Loop.
Modified ThisWorkbook.Sheets().
Closed For Next Loop.
The Code
Option Explicit
Sub Main()
Const cStrSheet As String = "Sheet7,Sheet8,Sheet9" '***
Dim vntSheet As Variant ' ***
Dim iSheet As Integer ' ***
Dim Wb As Workbook
Dim Data, Last
Dim i As Long, j As Long, k As Long, a As Long
Dim Dest As Range
'Refer to the template
Set Wb = Workbooks("SpecializedSkillsTemplate.xlsx")
'Refer to the destination cell
Set Dest = Wb.Sheets("Manager Summary").Range("B1")
vntSheet = Split(cStrSheet, ",") '***
For iSheet = 0 To UBound(vntSheet) '***
'Read in all data
With ThisWorkbook.Sheets(vntSheet(iSheet)) '***
Data = .Range("Z2", .Range("A" & Rows.Count).End(xlUp))
End With
Wb.Activate
'Process the data
For i = 1 To UBound(Data)
'Manager changes?
If Data(i, 1) <> Last Then
'Skip the first
If i > 1 Then
'Scroll into the view
Dest.Select
'Save a copy
Wb.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & _
ValidFileName(Last & "_Assessment.xlsx")
End If
'Clear the employees
Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
'Remember this manager
Last = Data(i, 1)
'Start the next round
j = 0
End If
'Write the employee data into the template
a = 0
For k = 2 To UBound(Data, 2)
Dest.Offset(a, j) = Data(i, k)
a = a + 1
Next
'Next column
j = j + 1
Next
Next ' iSheet '***
End Sub
I have a VBA macro which is currently copying data from Setup sheet and updating into the respective tables into Read_Only sheet for the first time. But when I click second time, it is adding the data into the respective tables in Read_Only sheet.
Now what I want is, if I click second time, it should first clear the existing data from that respective table in Read_Only sheet and then update the new data into that table. (For example: In 1st table, there were 10 rows of data, now when I click 2nd time I have only 8 rows of data, then macro should clear data existing 10 rows of data and update this new 8 rows of data and then delete the 2 empty two rows. This should be Dynamic, since number of rows may vary every time while updating new data)
Here is the existing code:
Sub copyData()
Dim wsSet As Worksheet
Dim wsRead As Worksheet
Dim rngSearch As Range
Dim lastRow As Integer
Dim i As Integer
Dim wRow As Integer
Dim strCat As String
Dim catRow As Integer
Set wsSet = ActiveWorkbook.Worksheets("Budget_Setup")
Set wsRead = ActiveWorkbook.Worksheets("WBS_Overview_Read_only")
Set rngSearch = wsRead.Range("A12:A1000") 'range in READ to search for category
lastRow = wsSet.Range("B16").End(xlDown).Row 'last row of data in SET
Application.ScreenUpdating = False
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1
If wsRead.Range("e" & wRow).Value <> "" Then
wsRead.Range("a" & wRow).EntireRow.Insert
End If
End If
wsSet.Range("b" & i & ":f" & i).Copy
wsRead.Range("a" & wRow).PasteSpecial
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Set wsRead = Nothing
Set wsSet = Nothing
End Sub
This code will first delete all the existing data in each of the sections on the Read_Only sheet; then, with one modification, your code can be run as is.
Add this line of code immediately after Application.ScreenUpdating = False
' Erase all data in the Read Only Sheet
Set currentData = wsRead.Columns(4).Find("Subject")
Do
wsRead.Range(currentData.Offset(2, 0), _
currentData.Offset(2, 0).End(xlDown).Offset(-1, 0)).EntireRow.Delete
Set currentData = wsRead.Columns(4).FindNext(currentData)
Loop Until Not currentData Is Nothing And currentData.Row = 12
This code uses the "Subject" and the "Budgeted Cost" cells to delete the existing data between it.
Next, add the following line of code immediately after wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert
this will add the first blank row of data to a given section. Your existing code will then insert the new data into the blank row
See if this works for you. I added one line to your code:
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert 'I added this line
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1 'end of data
If wsRead.Range("e" & wRow).Value <> "" Then
Now, run this code before running yours.
Sub deletePhases()
' delete phases in Setup from ReadOnly
Dim r As Range, Col As Collection
Dim x As Long, l As Long
With Budget_Setup
Set r = .Range("b17", .Cells(.Rows.Count, 2).End(xlUp))
End With
If r.Row < 17 Then Exit Sub 'no data
Set Col = New Collection 'build unique list
On Error Resume Next
For x = 1 To r.Rows.Count
Col.Add Left(r(x).Value, 3), Left(r(x).Value, 3)
Next x
With ReadOnly
For x = 1 To Col.Count
l = .Columns(1).Find(Col(x)).Offset(1).Row '1 below heading
Do Until .Cells(l, 1) = "" 'end of phase data
.Rows(l).Delete
Loop
Next x
End With
End Sub
I'm not sure how you're defining your Phase.71, Phase.72, etc, ranges, but with the information we have, this might work for you.
Sub clearAll()
Dim r As Range, vArr, v
vArr = Array("Phase.71", "Phase.72", "Phase.73", "Phase.74", "Phase.75")
For Each v In vArr
Set r = ReadOnly.Range(v)
Set r = r.Offset(2).Resize(r.Rows.Count - 4)
r.ClearContents
Next v
End Sub
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