Need help copy/pasting in Excel VBA from one workbook to another - excel

I need to find out how to write some basic code that will take each cell's value (which will be an ID number) from a selected range, then match it to a cell in a master workbook, copy said cell's entire row, then insert it into the original document in place of the ID number. Here's the kicker: certain ID numbers may match with several items, and all items that have that number must be inserted back into the document. Here's an example:
Master Document Workbook
A B C D A B C D
1 a ab ac 2
2 b bc bd 3
2 b be bf
3 c cd de
I would select the cells containing 2 and 3 in the Workbook, which after running the code would give me this:
Workbook
A B C D
2 b bc bd
2 b be bf
3 c cd de
Here's what I have going on so far but it's a total mess. The only thing it's managed to successfully do is store the selected range in the Workbook I want to paste to. It won't compile past that because I don't understand much of the syntax in VBA:
Sub NewTest()
Dim rng As Range
Dim FirstRow As Range
Dim CurrentCol As String
Dim FirstRowVal As Integer
Dim CurrentColVal As Variant
Dim rngOffset As Range
CurrentCol = "Blah"
Set FirstRow = Application.InputBox("Select the row containing your first raw material", Type:=8)
FirstRowVal = FirstRow.Row
Set rng = (Application.InputBox("Select the cells containing your IC numbers", "Obtain Materials", Type:=8))
Set rngOffset = rng.Offset(0, FirstRowVal)
CurrentColVal = rng.Column
Call CopyPaste
End Sub
Sub CopyPaste()
Dim Blah As Range
Set x = Workbooks.Open("Workbook Path")
Workbooks.Open("Workbook Path").Activate
Set y = Workbooks.Open("Master Path")
Workbooks.Open("Master Path").Activate
With x
For Each Cell In rng
x.Find(rng.Cell.Value).Select
If Selection.Offset(0, -1) = Selection Then
Selection.EntireRow.Copy
Selection = Selection.Offset(0, -1)
Else
Selection.EntireRow.Copy
Blah = Selection
End If
Workbooks.Open("Workbook Path").Activate
Sheets("Formula Sheet").Select
Blah.Insert (rng.Cell)
End
Sheets("sheetname").Cells.Select
Range("A1").PasteSpecial
'Sheets("sheetname").PasteSpecial
.Close
End With
With x
.Close
End With
End Sub
Would very much appreciate anyone who could help point me in the right direction. Thanks.

I'll bite, you can use the output array to populate any range on any worksheet.
Sub FindAndMatch()
Dim arrMatchFrom() As Variant, arrMatchTo() As Variant, arrOutput() As Variant
Dim i As Integer, j As Integer, counter As Integer
counter = 0
arrMatchFrom = Range("A2:D6")
arrMatchTo = Range("G2:G3")
For i = LBound(arrMatchTo, 1) To UBound(arrMatchTo, 1)
For j = LBound(arrMatchFrom, 1) To UBound(arrMatchFrom, 1)
If arrMatchTo(i, 1) = arrMatchFrom(j, 1) Then
counter = counter + 1
ReDim Preserve arrOutput(4, counter)
arrOutput(1, counter) = arrMatchTo(i, 1)
arrOutput(2, counter) = arrMatchFrom(j, 2)
arrOutput(3, counter) = arrMatchFrom(j, 3)
arrOutput(4, counter) = arrMatchFrom(j, 4)
End If
Next
Next
For i = 1 To counter
For j = 1 To 4
Debug.Print arrOutput(j, i)
Cells(9 + i, j) = arrOutput(j, i)
Next
Next
End Sub

Related

How to use VBA to copy data from one sheet to another if it fulfill three different conditions?

I wanted to copy data that fulfil a few criteria from one sheet to another using VBA.
My goal:
Copy Cell in column E, F and G in Sheet FP to column R, S and T in Sheet MUOR if it meets my conditions.
My conditions:
(1) Cell in Column D & Cell in Column P (in Sheet MUOR) must meet the condition in Column I of Sheet FP.
(2) If Cell in Column D is empty, skip to next Cell in Column D.
(3) Column R, S or T must be empty before pasting it. If not empty, move to the next cell that meets the condition. (Do not replace or duplicate the data)
Other information: Max Batch No (Column D) per day is 3;
Issue Facing:
My current VBA code doesn't recognise my conditions. It totally ignored my Day 1 data, and it duplicated all the Day 2 data.
Please refer to the attached images.
Sheet MUOR
Sheet FP
My expected Result
Sample Data here
My current code as below:
Sub LinkData()
Dim y As Long
Dim x As Long
Dim z As Long
Dim lr As Long
Dim arr As Variant
Dim FP As Worksheet
Dim MUOR As Worksheet
Set FP = ThisWorkbook.Sheets("FP")
Set MUOR = ThisWorkbook.Sheets("MUOR")
With FP
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = .Range("A1:I" & lr).Value
End With
With MUOR
For y = 11 To 363
For z = y - 1 To y + 8
For x = LBound(arr) To UBound(arr)
If Cells(11 + y, 4) <> "" And Cells(11 + y, 4) & Cells(10 + z, 16) = arr(x, 9) And IsEmpty(Cells(10 + z, 18)) Then
.Cells(10 + z, 18) = arr(x, 5)
.Cells(10 + z, 19) = arr(x, 8)
.Cells(10 + z, 20) = arr(x, 7)
Else
End If
Next x
Next z
Next y
End With
End Sub
Any VBA expert please help me.
Much appreciated!
I think code below should give expected output, but not totally sure, since the workbook uploaded/shared seems to differ from the screenshots in the question.
Option Explicit
Private Sub LinkData()
Dim arrayFromFPSheet() As Variant
arrayFromFPSheet = GetSourceArray()
Dim MUOR As Worksheet
Set MUOR = ThisWorkbook.Worksheets("MUOR")
Dim rangesToLoopThrough As Range
Set rangesToLoopThrough = GetDestinationAreas(MUOR)
With MUOR
Dim area As Range
For Each area In rangesToLoopThrough.Areas
Debug.Assert area.Rows.CountLarge > 1 And area.Rows.CountLarge < 20
Dim areaFirstRowIndex As Long
areaFirstRowIndex = area.Rows(1).Row
Dim areaLastRowIndex As Long
areaLastRowIndex = area.Rows(area.Rows.Count).Row
Dim readRowIndex As Long
For readRowIndex = areaFirstRowIndex To areaLastRowIndex
If Not IsCellEmpty(.Cells(readRowIndex, "D")) Then
Dim batchNumber As String
batchNumber = CStr(.Cells(readRowIndex, "D"))
Dim writeRowIndex As Long
For writeRowIndex = areaFirstRowIndex To areaLastRowIndex
If IsCellEmpty(.Cells(writeRowIndex, "R")) And IsCellEmpty(.Cells(writeRowIndex, "S")) And IsCellEmpty(.Cells(writeRowIndex, "T")) Then
Dim Grade As String
Grade = CStr(.Cells(writeRowIndex, "P"))
Dim batchNumberAndGrade As String
batchNumberAndGrade = batchNumber & Grade
Dim n As Variant
n = Application.CountIfs(.Range("P" & areaFirstRowIndex, "P" & writeRowIndex), Grade, .Range("R" & areaFirstRowIndex, "R" & writeRowIndex), batchNumber) + 1
Debug.Assert IsNumeric(n)
Dim sourceRowIndex As Long
sourceRowIndex = GetRowIndexOfNthMatch(n, arrayFromFPSheet, batchNumberAndGrade, 9)
If sourceRowIndex > 0 Then
.Cells(writeRowIndex, "R") = arrayFromFPSheet(sourceRowIndex, 5)
.Cells(writeRowIndex, "S") = arrayFromFPSheet(sourceRowIndex, 8)
.Cells(writeRowIndex, "T") = arrayFromFPSheet(sourceRowIndex, 7)
End If
End If
Next writeRowIndex
End If
Next readRowIndex
Next area
End With
End Sub
Private Function GetDestinationAreas(ByVal someSheet As Worksheet) As Range
' Crudely clusters/groups destination sheet into areas (which
' should be date-specific, although this function will not check/verify
' output).
Const START_ROW_INDEX As Long = 10
Dim outputRange As Range
Set outputRange = someSheet.Range("C" & START_ROW_INDEX, "C" & someSheet.Rows.Count)
On Error Resume Next
Set outputRange = outputRange.SpecialCells(xlCellTypeConstants) ' Will raise error if no constants found.
On Error GoTo 0
Debug.Assert Not (outputRange Is Nothing)
Set GetDestinationAreas = outputRange
End Function
Private Function GetSourceArray() As Variant
With ThisWorkbook.Worksheets("FP")
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim outputArray() As Variant
outputArray = .Range("A1:I" & lastRow).Value
End With
GetSourceArray = outputArray
End Function
Private Function IsCellEmpty(ByVal someCell As Range) As Boolean
' https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/isempty-function
' "IsEmpty only returns meaningful information for variants."
' So using below function instead.
IsCellEmpty = Len(CStr(someCell.Value)) = 0
End Function
Private Function GetRowIndexOfNthMatch(ByVal n As Long, ByRef someArray() As Variant, ByVal someText As String, ByVal targetColumn As Long) As Long
' Returns a 1-based row index of the nth occurrence of text value
' in target column of array or 0 if unsuccessful.
Debug.Assert n > 0
Dim rowIndex As Long
For rowIndex = LBound(someArray, 1) To UBound(someArray, 1)
If someArray(rowIndex, targetColumn) = someText Then
Dim matchCount As Long
matchCount = matchCount + 1
If matchCount = n Then
GetRowIndexOfNthMatch = rowIndex
Exit Function
End If
End If
Next rowIndex
End Function
Thanks for all the information you provided in the question. It makes it easier to answer.

Paste incremental values in VBA

How can I run a loop in VBA so that the sequence looks like in green an pink color?
Because when I use this code is actually just paste all number 1. not increase.
ThisWorkbook.Sheets("Main").Range("E2:E" & iLast).FillDown
This may not be the cleanest way, but it will do the trick.
Sub InsertSequenceAndColours()
Dim ws As Worksheet
Dim rng As Range
Dim iLast As Integer
Dim i As Integer
Dim iSeq As Integer
Dim iColRGB(2, 3) As Integer
Dim iIncremColour As Integer 'used to determine the colour to use
Dim iColour As Integer
'set RGB Colours; change as needed
'colour 0 (green)
iColRGB(0, 1) = 146
iColRGB(0, 2) = 208
iColRGB(0, 3) = 80
'colour 1 (pink)
iColRGB(1, 1) = 255
iColRGB(1, 2) = 225
iColRGB(1, 3) = 236
'change to 0 if you want to start with colour 1 (pink)
iIncremColour = 1
'declare worksheet to work on
Set ws = ThisWorkbook.Worksheets(Sheet1.Name)
With ws
'find last row
iLast = .Cells(.Rows.Count, "C").End(xlUp).Row
'loop through column C
For i = 2 To iLast
iSeq = iSeq + 1
If .Cells(i, 3).Value <> .Cells(i - 1, 3).Value Then
iSeq = 1
iIncremColour = iIncremColour + 1
End If
'assign Seq. No. to cell (column E)
.Cells(i, 5).Value = iSeq
'find if iIncremColor is odd or even. output: 0 or 1
iColour = iIncremColour Mod 2
'assign colour to col C D E
.Range(Cells(i, 3), Cells(i, 5)).Interior.Color = _
RGB(iColRGB(iColour, 1), iColRGB(iColour, 2), iColRGB(iColour, 3))
Next i
End With
End Sub
It finds out the Seq "1" (Col E) by finding the first occurrence of "No" (Col C); Seq "2, 3" are just incremental (so it will work also with more than 3 occurrences).
Same with colour. For each "Seq 1" it increments a number; by checking if this number is odd or even it assign one colour or the other.
Please Note I use worksheet codename to work (if you're not familiar with it, please google it), which I strongly advise since it will work even if you decide to change the name of your worksheet in excel.
When VBA requests to work with worksheet name or index, you can trick it by using codename.Name or codename.Index.
Approach via array
You can fill an array and write it back to your target range:
Sub FlexibleRange()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Main") ' << change to your sheet name
Dim start As Long, last As Long, i As Long ' declare variables
start = 2: last = 100 ' <~~ change to your individual rows
Dim v: ReDim v(start To last, 1 To 1) ' variant datafield array, counter
For i = start To last
v(i, 1) = (i - start) Mod 3 + 1 ' assign values
Next i
ws.Range("E" & start & ":E" & last) = v ' write numbers to column E
End Sub
I got to solve it.
i use this formula
=MOD(ROW()-2,3)+1.
Thank's you all..appreciate your help. <3

Excel: VBA to copy values to specific row

I currently have a macro that copies the value from a specific cell from one sheet(BACKEND), and pastes in specific column in another sheet (EXPORT_DATA), in the next blank row.
Sub copy_values(Optional Source As String = "A1", Optional Source2 As String = "A1")
Dim R As Range
Dim col As Long
col = Range(Source).Column
Set R = Worksheets("EXPORT_DATA").Cells(Rows.Count, col).End(xlUp)
If Len(R.Value) > 0 Then Set R = R.Offset(1)
R.Value = Worksheets("BACKEND").Range(Source2).Value
End Sub
It works well, but I want to replace the the function in where it pastes the data in the next blank cell in a column, to a function in where it pastes the data in a row in where a cell holds a specified value.
For example, the older function would do the following
step 1:
c1 c2 c3
a b 4
c d 6
step 2 (after macro executed):
c1 c2 c3
a b 4
c d 6
c d 5
But I need a new function that does this:
step 2 (C1 value of "c" specified, macro executed):
c1 c2 c3
a b 4
c d 5
See how this goes for you. Not sure how you are calling etc but it should be a reasonable starting point. I only gave it a really quick test
Sub copy_values_SINGLE(cValue As Variant, Optional Source As String = "A1", Optional Source2 As String = "A1")
' Not sure of what value type c in your question would be but expects a single value to test against the column provided as Source
' Requires cValue to be provided
Dim R As Range
Dim col As Long
Dim destRow As Integer
col = Range(Source).Column
On Error Resume Next
destRow = 0
destRow = Worksheets("EXPORT_DATA").Columns(col).Find(cValue, SearchDirection:=xlPrevious).Row
If destRow = 0 Then destRow = Worksheets("EXPORT_DATA").Cells(Rows.Count, col).End(xlUp).Row + 1 ' if cValue isnt found reverts to the last row as per previous code
On Error GoTo 0
Set R = Worksheets("EXPORT_DATA").Cells(destRow, col)
R.Value = Worksheets("BACKEND").Range(Source2).Value
End Sub
This may work
Sub copy_values(Optional Source As String = "A1", Optional Source2 As String = "A1")
Dim R As Variant
Dim col As Long
col = Range(Source).Column
Dim mrn As String
Dim FoundCell As Excel.Range
Dim myVal As String
R = Worksheets("BACKEND").Range(Source2).Text
myVal = Worksheets("BACKEND").Range(Source2).Text
mrn = Worksheets("BACKEND").Range("A5").Value
Set FoundCell = Worksheets("EXPORT_DATA").Range("A:A").Find(what:=mrn, lookat:=xlWhole, searchdirection:=xlPrevious)
If Not FoundCell Is Nothing Then
' MsgBox (R & " " & col & " " & FoundCell.Row)
Worksheets("EXPORT_DATA").Range("Q" & FoundCell.Row).Value = R
Else
MsgBox "error"
End If
End Sub
Still not 100% certain, but I think this is what you are after. The file loop all values in column A of the EXPORT_DATA file and compared them to the value in cell A1 of the BACKEND worksheet. If it finds the value it replaces the value in column B, if it cannot find the value, it adds it at the end:
Sub copy_values_SINGLE()
Dim R As Range
Dim rowCount As Long
Dim varValue As Variant
rowCount = Application.WorksheetFunction.CountA(Worksheets("EXPORT_DATA").Range("A:A"))
For s = 1 To rowCount
If Worksheets("EXPORT_DATA").Range("A" & s).Value = Worksheets("BACKEND").Range("A1").Value Then
Worksheets("EXPORT_DATA").Range("A" & s & ":B" & s).Value = Worksheets("BACKEND").Range("A1:B1").Value
Exit For
Else
If s = rowCount Then
Set R = Worksheets("EXPORT_DATA").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
R.Value = Worksheets("BACKEND").Range("A1:B1").Value
End If
End If
Next s
End Sub
Let me know if this works for you.

how to adjust code for better performance

I am trying to make edge relation from excel file which are organized in rows,
A,B,C,
D,E
the aim is to create relationships from each row:
A,B
A,C
B,C
I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):
D," "
E, " "
Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.
Thank you so much,Will be great help.
My code:
Sub Transform()
Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2
Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long
Dim sourceRow As Range: For Each sourceRow In Selection.Rows
For colCounter = 1 To Selection.Columns.Count - 1
col1 = sourceRow.Cells(colCounter).Value
For colCounter2 = colCounter + 1 To Selection.Columns.Count
Set cell = sourceRow.Cells(, colCounter2)
If Not cell.Column = Selection.Column Then
Selection.Worksheet.Cells(targetRowNumber, 1) = col1
Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
targetRowNumber = targetRowNumber + 1
End If
Next colCounter2
Next colCounter
Next sourceRow
End Sub
I've played around with it - this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:
Sub Transform_New()
Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer
Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range
varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell
k = j
Do Until varArray(i, k) = ""
k = k + 1
If varArray(i, k) <> "" Then
rngDest.Value = varArray(i, j)
rngDest.Offset(0, 1).Value = varArray(i, k)
Set rngDest = rngDest.Offset(1, 0)
End If
Loop
Next
Next
End Sub

Normalizing Excel Grid Intersection data into a flat list

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

Resources