I have been struggling with this code. I want to loop through Column E beginning with E5, on the Sheet titled "pivot of proposal" (which is a pivot table); and every time it finds a cell with the value of "check" I want it to copy/paste value of cells A & B of the corresponding row to the sheet titled Check Payments in E & F, moving down a row each time but beginning on row 4. I tried to piece together other bits of code but it is not doing what I need it to.
Sub Loop_Check_Payments()
Dim c As Range
Dim IRow As Long, lastrow As Long, krow as long
Dim copyrow As Integer
Dim rSource As Range
Dim DataOrigin As Worksheet, DataDest As Worksheet, DataDestACH As Worksheet
On Error GoTo Whoa
'~~> Sheet Where "L" needs to be checked
Set DataOrigin = ThisWorkbook.Sheets("Pivot of proposal")
'~~> Output sheet
Set DataDest = ThisWorkbook.Sheets("CHECK PAYMENTS")
Set DataDestACH = ThisWorkbook.Sheets("ACH_WIRE PAYMENTS CASH POOLER")
Application.ScreenUpdating = False
'~~> Set you input range
Set rSource = Range("Payment_Method")
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
If c.Value = "Check" Then
DataDest.Cells(4 + IRow, 5) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(4 + IRow, 6) = DataOrigin.Cells(c.Row, 2)
IRow = IRow + 1
Else
DataDestACH.Cells(4 + kRow, 7) = DataOrigin.Cells(c.Row, 1)
DataDestACH.Cells(4 + kRow, 8) = DataOrigin.Cells(c.Row, 2)
kRow = kRow + 1
End If
Next c
Whoa:
MsgBox Err.Description
End Sub
Instead of trying to Copy/paste - you can do something like this (as PeterT alluded to in comments)
this will put values from columns A&B (ordinal 1 & 2) of the SOURCE to the same row/column in the destination:
If c.Value = "Check" Then
DataDest.Cells(c.Row, 1) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(c.Row, 2) = DataOrigin.Cells(c.Row, 2)
End If
Related
I cobbled together something that does work for me as is, but it runs very slowly and I'm sure the code can be simplified.
Sub CopyPasteValues()
Dim strSht1, strSht2 As String
Dim c, rng As Range
strSht1 = "Edit"
strSht2 = "LOB"
With ThisWorkbook.Sheets(strSht1)
Set rng = Range("J2:AJ37")
For Each c In rng
If Not c.Value = 0 Then
Cells(c.Row, 2).Copy
ThisWorkbook.Sheets(strSht2).Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Range(Cells(c.Row, 4), Cells(c.Row, 5)).Copy
ThisWorkbook.Sheets(strSht2).Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
c.Copy
ThisWorkbook.Sheets(strSht2).Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(c.Column).Copy
ThisWorkbook.Sheets(strSht2).Range("G" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next c
End With
End Sub
I appreciate any assistance.
As BigBen Mentioned, array method.
Super Fast.
Sub Move_Values_Array_Method()
Dim SourceSheet As Worksheet 'Source Worksheet
Dim DestinationSheet As Worksheet 'Destination Worksheet
Dim RG As Range 'Source Range
Dim InArr() 'Data In Array
Dim OutArr() 'Data Out Array
Dim X As Long 'Array X Position for purposes of iterating through array.
Dim Y As Long 'Array Y Position for purposes of iterating through array.
Dim Cnt As Long 'Found Value Count
Set SourceSheet = ThisWorkbook.Worksheets("Edit") 'Set Source Worksheet
Set DestinationSheet = ThisWorkbook.Worksheets("LOB") 'Set Dest Worksheet
Set RG = SourceSheet.Range("J2:AJ37") 'Set Source Range
ReDim OutArr(1 To RG.Cells.Count) 'Count Cells in Range, resize output array to be at least that big.
InArr = RG 'Transfer Range Data to Array
Cnt = 0
Debug.Print LBound(InArr, 1) & " - " & UBound(InArr, 1) 'Rows
Debug.Print LBound(InArr, 2) & " - " & UBound(InArr, 2) 'Columns
For Y = 1 To UBound(InArr, 1) 'For Each Row in Array (or each Y position)
For X = 1 To UBound(InArr, 2) 'For Each Column in Array (or each X position)
If InArr(Y, X) <> "" Then 'If not blank Value (you can change this to "If InArr(Y, X) <> 0 Then" if that works best for you.
Cnt = Cnt + 1 'Increment "found value count" by 1
OutArr(Cnt) = InArr(Y, X) 'Add found value to output array
End If
Next X
Next Y
'Output to Dest Sheet
DestinationSheet.Range("F2").Resize(UBound(OutArr, 1), 1).Value = Application.Transpose(OutArr())
End Sub
Based on the information in your previous comments, try these alternative solution using formulas and filters...
1) Array Formulas
To note:
I have put everything on one sheet for clarity, but it works just as well over multiple sheets, or even workbooks.
If you want to filter the entire sheet, with same column order, you only need to enter formula once and expand "Array" criteria in formula to encapsulate entire data set.
Formula used in cell "J4" = "=FILTER($I$4:$I$30,$C$4:$C$30>0)"
(filter range I4 to I30 to show rows where value in range C4 to C30 is greater than 0)
2) Directly Filter
Alternatively, you could (either manually or programmatically) copy all data to LOB sheet, (or selectively copy), then filter for Qty>0.
After countless efforts to keep the array "newvarray" within range, I am now running into a result of an empty array from a 278 line column. I believe this is also the root cause of my endgame function not executing (pasting unmatched values into the rolls sheet)?
Clarification: the actualy empty cells report on locals as "Empty", the columns with string report as " "" "
Dim oldsht As Worksheet
Dim newsht As Worksheet
Dim rollsht As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Set oldsht = ThisWorkbook.Sheets("Insert Yesterday's Report Here")
Set newsht = ThisWorkbook.Sheets("Insert Today's Report Here")
Set rollsht = ThisWorkbook.Sheets("Rolls")
Dim OldVArray(), NewVArray(), RollArray() As String
ReDim Preserve OldVArray(1 To oldsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 5 To 5)
ReDim Preserve NewVArray(2 To newsht.Range("a" & Rows.Count).End(xlUp).Row, 5 To 5)
ReDim Preserve RollArray(1 To rollsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 3 To 3)
For a = 2 To oldsht.Range("E" & Rows.Count).End(xlUp).Row
OldVArray(a, 5) = oldsht.Cells(a, 5)
Next a
For b = 2 To newsht.Range("E" & Rows.Count).End(xlUp).Row
NewVArray(b, 5) = newsht.Cells(b, 5)
Next b
For c = 2 To rollsht.Range("C" & Rows.Count).End(xlUp).Row
RollArray(c, 3) = rollsht.Cells(c, 3)
Next c
Dim Voyage As String
For a = 2 To UBound(OldVArray)
Voyage = OldVArray(a, 5)
For b = 2 To UBound(NewVArray)
voyage2 = NewVArray(b, 5)
If voyage2 <> Voyage Then
If voyage2 <> "" Then
For Each cell In NewVArray
voyage2 = rollsheet.Range("C:C")
Next
End If
End If
Next
Next
Here are snips of sample idea, highlighted are the rows that need to be found, and the voyage that changed is in orange. Third on Rolls would be the output of the macro.
Oldsheet:
Newsheet:
Rolls:
Untested, but this is how I'd do it. Just going from your screenshots. If your actual data looks different then you will need to make some adjustments.
Sub test()
Dim wb As Workbook, oldsht As Worksheet, newsht As Worksheet, rollsht As Worksheet
Dim c As Range, id, col, cDest As Range, copied As Boolean, m
Set wb = ThisWorkbook
Set oldsht = wb.Sheets("Insert Yesterday's Report Here")
Set newsht = wb.Sheets("Insert Today's Report Here")
Set rollsht = wb.Sheets("Rolls")
'next empty row on Rolls sheet
Set cDest = rollsht.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'loop colA on new sheet
For Each c In newsht.Range("A2:A" & newsht.Cells(Rows.Count, "A").End(xlUp).row).Cells
id = c.Value 'identifier from Col A
If Len(id) > 0 Then
m = Application.Match(id, oldsht.Columns("A"), 0) 'check for exact match on old sheet
If Not IsError(m) Then
'got a match: check for updates in cols B to C
copied = False
For col = 2 To 3
If c.EntireRow.Cells(col).Value <> oldsht.Cells(m, col).Value Then
If Not copied Then 'already copied this row?
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy changed row
Set cDest = cDest.Offset(1) ' next empy row
copied = True
End If
cDest.EntireRow.Cells(col).Interior.Color = vbRed 'flag updated value
End If
Next col
Else
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy new row
Set cDest = cDest.Offset(1) ' next empy row
End If
End If
Next c
End Sub
I need the expert help in VBA as I am new. Actually I am looking for Vba code for Consecutive Count on the bases of two column (Serial Number and Alert Code) on button click event. The Column row are not fixed (dynamically change). The Consecutive count is maximum repeat count for Alert Code per Serial number. This should display in output worksheet as per max repeat Alert count per Serial number
Input Worksheet:
Expected Output :
The repeat count work as below pattern from Input sheet (Just for reference only).
Mine source code as below but this does not reference the 1st Column Serial Number (This only work for One column like AlertCode) :
Sub ConsecutiveCount()
Dim lr As Long, c As Range, a As Long
Application.ScreenUpdating = False
lr = Worksheets("Count2").Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("B2:B" & lr)
If c.Value <> c.Offset(1).Value Then
a = Cells(c.Row, 3).End(xlUp).Row
' Range(Cells(c.Row, 4), Cells(c.Row, 4).End(xlUp).Offset(1)).Value = c.Row - a
Cells(c.Row, 3).Value = c.Row - a
Else
End If
Next c
Application.ScreenUpdating = True
End Sub
Current Output (Serial number not included)
Screenshot(s) / here(♪) refers:
Named ranges/setup
First, define a couple of named ranges to assist with referencing / formulating in VBA:
Name: range_data: dynamic range that references the two columns of interest (here, col 1&2 in Sheet1):
Refers to: =Sheet1!$D$3:OFFSET(Sheet1!$E$3,COUNTA(Sheet1!$E$3:$E$99995)-1,0,1,1)
Name: range_summary_startcell: a static range that references the desired upper-left cell of the output table / summary.
Refers to: =Sheet1!$G$3
The summary table itself shall comprise a number of rows (depending upon range_data) and 3 columns (given the input/Q) - this will be produced by the macro (code below) and can be seen in screenshot above (G3:I5) - the macro functions shall determine the appropriate dimensions automatically
Code
With these two named ranges (i.e. 'range_data' & 'range_summary_startcell') defined, the following VB code produces the desired output per your Q:
Sub Macro_Summary()
'
'JB_007 07/01/2022
'
'
Application.ScreenUpdating = True
Range("range_summary_startcell").Select
ActiveCell.Formula2R1C1 = "=UNIQUE(range_data)"
ActiveSheet.Calculate
x = ActiveCell.End(xlDown).Row
Set range_count = ActiveCell.Offset(0, 2)
range_count.Select
range_count.Formula2R1C1 = _
"=COUNTIFS(INDEX(range_data,0,2),RC[-1],INDEX(range_data,0,1),RC[-2])"
Selection.AutoFill Destination:=Range(range_count, range_count.Offset(x - range_count.Row))
ActiveSheet.Calculate
End Sub
Caveats: assumes you have Office 365 compatible version of Excel
GIF - Running Macro
Notes (♪) saved as macro-free workbook for your own security if you wish to download underlying workbook - otherwise identical to screenshot(s) in this proposed soln.
Sub ConsecutiveCount()
Dim srcLastRow As Long, cntConsec As Long, i As Long
Dim rng As Range
Dim srcArr() As Variant
Dim srcSht As Worksheet
Dim destsht As Worksheet
Dim destArr() As Variant
Dim combID As String
Dim splitID As Variant
Application.ScreenUpdating = False
Set srcSht = Worksheets("Input")
Set destsht = Worksheets("Output")
With srcSht
srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' include 1 blank line
srcArr = .Range(.Cells(2, "A"), .Cells(srcLastRow, "B"))
End With
Dim dict As Object
Dim dKey As Variant
Set dict = CreateObject("Scripting.dictionary")
cntConsec = 0
For i = LBound(srcArr) To UBound(srcArr)
cntConsec = cntConsec + 1
If i <> UBound(srcArr) Then
If srcArr(i, 1) <> srcArr(i + 1, 1) Or srcArr(i, 2) <> srcArr(i + 1, 2) Then
combID = srcArr(i, 1) & "|" & srcArr(i, 2)
If dict.Exists(combID) Then
' check if sum is more
If dict(combID) < cntConsec Then ' If new max for combination
dict(combID) = cntConsec
End If
Else
' add to dictionary
dict(combID) = cntConsec
End If
cntConsec = 0
End If
End If
Next i
ReDim destArr(1 To dict.Count, 1 To 3)
i = 0
For Each dKey In dict.keys
splitID = Split(dKey, "|")
i = i + 1
destArr(i, 1) = splitID(0)
destArr(i, 2) = splitID(1)
destArr(i, 3) = dict(dKey)
Next dKey
destsht.Range("A2").Resize(UBound(destArr), 3).Value = destArr
Application.ScreenUpdating = True
End Sub
I have a macro that copies and pastes rows from input sheet to output sheet. I find PRODUCT NAME and END DATE, then copy the whole row and transpose when pasting it. I am using transpose because I want to have vertical table.
I have a problem with images because I don't know how to copy them to proper cell so they match with Name and Date. I've managed to write a script that is copying and pasting images but it puts all of them in cell A1. When I want to add range to target_sheet.Paste I am getting vba method intersect of object _application failed error.
Below you can see how input and output sheets look.
Input sheet:
Expected output sheet (with only 3 columns) :
It is very important to know that 'input' sheet contains many products with names, prices and images and there is always a blank row between them. The number of images in each row can be different (from 1 to 25).
Sub copy_paste()
Dim Cell As Range
Dim src_rng As String
Dim LR As Long
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim pic As Shape
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
target_sheet.Cells.Delete
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A10000").End(xlUp).Row + 1
If Cell.Value = "Name" Then
Cell.EntireRow.Copy
target_sheet.Range("A" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste, transpose end line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("B10000").End(xlUp).Row + 1
If Cell.Value = "Date" Then
Cell.EntireRow.Copy
target_sheet.Range("B" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste image
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("C10000").End(xlUp).Row + 1
If Cell.Value = "Image" Then
For Each pic In source_sheet.Shapes
If Not Application.Intersect(pic.TopLeftCell, Range(src_rng)) Is Nothing Then
pic.CopyPicture
target_sheet.Paste
End If
Next pic
End If
Next
Application.ScreenUpdating = True
End Sub
Please, try the next code. It follows the logic deduced from your last question edit, respectively: the former "Name" becomes "Product Name", "Date" becomes "End Date" and the row keeping the pictures is the one below "Product Name" row. It is able to process two or three product names/pictures per group:
Sub copy_paste()
Dim Cell As Range, src_rng As String, LR As Long
Dim source_sheet As Worksheet, target_sheet As Worksheet
Dim pic As Shape, arrPAddr, rngTr As Range, k As Long
Dim cellRHeight As Range, nrShapesPerRange As Long 'to be 2 or 3
nrShapesPerRange = 2 'Choose here initial number of shapes per row (2 or 3)
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
ReDim arrPAddr(1 To 2, 1 To source_sheet.Shapes.count): k = 1
target_sheet.cells.Delete: For Each pic In target_sheet.Shapes: pic.Delete: Next
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A" & rows.count).End(xlUp).row + 1
If Cell.value = "Product Name" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("A" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
arrPAddr(1, k) = Cell.Offset(1, 1).Address
arrPAddr(2, k) = rngTr.Offset(, 2).Address: k = k + 1
arrPAddr(1, k) = Cell.Offset(1, 2).Address
arrPAddr(2, k) = rngTr.Offset(1, 2).Address: k = k + 1
If nrShapesPerRange = 3 Then
arrPAddr(1, k) = Cell.Offset(1, 3).Address
arrPAddr(2, k) = rngTr.Offset(2, 2).Address: k = k + 1
End If
If cellRHeight Is Nothing Then Set cellRHeight = Cell.Offset(1)
End If
LR = target_sheet.Range("B" & rows.count).End(xlUp).row + 1
If Cell.value = "End Date" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("B" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
End If
Next
ReDim Preserve arrPAddr(1 To 2, 1 To k - 1)
'Making the row height in target_sheet equal to source_sheet column with:
target_sheet.Range("2:" & LR + 3).EntireRow.RowHeight = source_sheet.Range("A16").EntireRow.RowHeight
target_sheet.Range("A:C").EntireColumn.AutoFit
target_sheet.Range("C1").EntireColumn.ColumnWidth = cellRHeight.EntireColumn.ColumnWidth
'copy paste image:
Dim i As Long
For Each pic In source_sheet.Shapes
For i = 1 To UBound(arrPAddr, 2)
If pic.TopLeftCell.Address = arrPAddr(1, i) Then
pic.Copy: target_sheet.Paste
With target_sheet.Shapes(target_sheet.Shapes.count)
.top = target_sheet.Range(arrPAddr(2, i)).top + (target_sheet.Range(arrPAddr(2, i)).RowHeight - pic.height) / 2
.left = target_sheet.Range(arrPAddr(2, i)).left
End With
Exit For
End If
Next i
Next
Application.ScreenUpdating = True
target_sheet.Activate
MsgBox "Ready..."
End Sub
Plese, test the code and send some feedback
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