I have a mapping table which I use for matching column headers of two separate sheets (Sheet1 and Sheet2). But when I also want to match the row headers (months) the code is matching the rows, not the cells on column A. Any ideas how can I make this work? Thank you in advance! :)
Sheet1- src:
Sheet2- trgt (After I run the code, it should also match Oct, Nov, Dec):
,
Mapping table:
Sheet2- What I need:
Public Sub ceva()
Application.ScreenUpdating = False
stack "Sheet1", "Sheet2", "Mapping"
Application.ScreenUpdating = True
End Sub
Public Sub stack (ByVal Sheet1 As String, ByVal Sheet2 As String, ByVal Mapping As String)
Dim rng As Range, src As Worksheet, trgt As Worksheet, helper As Worksheet
Dim sht As Worksheet
Dim dctCol As Dictionary, dctHeader As Dictionary
Dim strKey1 As String, strKey2 As String
Dim strItem As String, col As Integer
Dim LastRow As Long, LastCol As Long
Set src = Worksheets(Sheet1)
Set trgt = Worksheets(Sheet2)
Set helper = Worksheets(Mapping)
LastRow = trgt.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = trgt.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set dctCol = New Dictionary
arr1 = src.Range("A1:F9")
''arr1 = src.Range("A4").End(xlDown).End(xlToRight)
For j = 2 To UBound(arr1, 2)
strKey1 = Trim(arr1(1, j)) & "," & Trim(arr1(2, j)) & "," & Trim(arr1(3, j))
dctCol(strKey1) = j
Next
'build a dictionary to translate 2 headers to 3 headers
Set dctHeader = New Dictionary
arrHelp = helper.Range("A2:E6")
For i = 1 To UBound(arrHelp)
strKey2 = Trim(arrHelp(i, 4)) & "," & Trim(arrHelp(i, 5)) '2 header key
strItem = Trim(arrHelp(i, 1)) & "," & Trim(arrHelp(i, 2)) & "," & Trim(arrHelp(i, 3))
dctHeader(strKey2) = strItem
Next
'update sheet2 with numbers from sheet1
arr2 = trgt.Range("A1:F12")
For j = 2 To 6
'work backwards to find the column
strKey2 = Trim(arr2(1, 2)) & "," & Trim(arr2(2, j)) '2 headers
strKey1 = dctHeader(strKey2)
col = dctCol(strKey1)
For i = 3 To 12
If src.Cells(i + 1, "A").Value = trgt.Cells(i, "A").Value Then
arr2(i, j) = arr1(i + 1, col)
Else
End If
Next
Next
trgt.Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2
End Sub
Build another dictionary for the months to row lookup
'update sheet2 with numbers from sheet1
arr2 = trgt.Range("A1:F12")
' month to row
Dim dctRow As Dictionary, key As String
Set dctRow = New Dictionary
For j = 4 To UBound(arr1)
dctRow(Trim(arr1(j, 1))) = j
Next
For j = 2 To 6
'work backwards to find the column
strKey2 = Trim(arr2(1, 2)) & "," & Trim(arr2(2, j)) '2 headers
strKey1 = dctHeader(strKey2)
col = dctCol(strKey1)
For i = 3 To 12
key = arr2(i, 1)
If dctRow.Exists(key) Then
arr2(i, j) = arr1(dctRow(key), col)
End If
Next
Next
Related
The following code successfully executes for small data sets:
Option Explicit
Option Base 1
Sub Left()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ws1, _
ws2 As Worksheet, _
wb As Workbook
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Adj")
Set ws2 = wb.Worksheets("Deleted")
Dim a, _
b, _
i, _
j, _
k As Long
a = 957
b = 290150
Dim Item1, _
Item2, _
Arr() As Variant
With ws2
For i = 2 To a
.Cells(i, 6) = Left(.Cells(i, 1), 11)
.Cells(i, 7) = Right(.Cells(i, 1), 4)
Next i
End With
With ws1
For j = 2 To b
ReDim Preserve Arr(j - 1)
Item1 = Chr(34) & .Cells(j, 7) & Chr(34)
Item2 = Chr(34) & .Cells(j, 9) & Chr(34)
On Error Resume Next
k = Evaluate("=MATCH(1,('Deleted'!F:F = " & Item1 & ")*('Deleted'!G:G = " & Item2 & "),0)")
If Err.Number = 13 Then
Arr(j - 1) = ""
Else: Arr(j - 1) = k
End If
On Error GoTo 0
Next j
.Range(.Cells(2, 15), .Cells(b, 15)) = WorksheetFunction.Transpose(Arr())
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
However, for large data sets - such as 290,150 rows - the macro spins its wheels. It's known that Evaluate is expensive to run and I have tried running for sample sizes of 30 (success) and 1,000 (unsuccessful) and debugged carefully. Obviously in-cell array formulation drag-and-drop is not a practical alternative. So, the problem reduces to resolving endless spinning for the given multiple criteria match function required.
How do I bypass this constraint?
Try this approach using a dictionary as a lookup:
Sub Left()
Dim wsAdj As Worksheet, wsDel As Worksheet, wb As Workbook
Dim lrDel As Long, lrAdj As Long, r As Long
Dim dict, t, arr, arrG, arrI, arrRes, k
Set wb = ThisWorkbook
Set wsAdj = wb.Worksheets("Adj")
Set wsDel = wb.Worksheets("Deleted")
lrAdj = 290150
lrDel = 957
t = Timer
'load a dictionary with lookup values constructed from wsDel ColA
Set dict = CreateObject("scripting.dictionary")
arr = wsDel.Range("A2:A" & lrDel).Value
For r = 1 To UBound(arr, 1)
k = Left(arr(r, 1), 11) & Chr(0) & Right(arr(r, 1), 4)
dict(k) = r + 1 '+1 to adjust for starting at row 2
Next r
arrG = wsAdj.Range("G2:G" & lrAdj).Value 'get the match columns as arrays
arrI = wsAdj.Range("I2:I" & lrAdj).Value
ReDim arrRes(1 To UBound(arrG, 1), 1 To 1) 'resize the "result" array
'loop the values from wsAdj
For r = 1 To UBound(arrG, 1)
k = arrG(r, 1) & Chr(0) & arrI(r, 1) 'build the "key"
If dict.exists(k) Then
arrRes(r, 1) = dict(k) 'get the matched row
End If
Next r
wsAdj.Cells(2, 15).Resize(UBound(arrRes, 1), 1).Value = arrRes 'put the array on the sheet
Debug.Print "done", Timer - t ' <1 sec
End Sub
Stating Ranges instead of Columns and removing ReDim on loop helped.
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
I am using a macro to re-organise 4600 lines of data into a more efficient layout. Currently, i have a macro but it misses data or puts data in the wrong place.
From the old data, the column A is notification number, column FO is sheet number and GB is zone number. Whilst column C is the data that is wanting to be inputted. So currently (as the photo shows, the data is very unorganisedand unreadable.
In the outputted sheet, the notification number is put in Row 1 in columns F on wards (No duplicates). In Column B and C is zone and sheet number respectively (No duplicates). Then, using the old data, plot Column C values in the correct column(Depending on notification number) and the correct row (depending on zone and sheet number).
I have achieved half of this, but not all values are not be inputted correctly.
I currently use range.find to see if the zone number exists, and if it doesn't add the zone value and sheet number into the last used row. However, if the zone number is found but the corresponding sheet number is different, then add these values and then also add the values from column C. However, if the correct cell is filled, find the next available cell in column that is empty and input value.
But, I cant find a better way to check these values than using range.find but i feel it is missing values and not comparing both values correctly.
Sub GenerateTable()
Application.ScreenUpdating = False
Dim RawDataWsNotificationRng, ModifiedDataWsNotificationRng As Variant
Dim cell As Range
Dim RawDataWsNotificationlrow, ModifiedDataWsNotificationlcolnum, ModifiedDataWsZoneLrow As Long
Dim ModifiedDataWsNotificationlcol As String
Dim serverfilename, DataSheetName, Newsheetname As String
Dim wkbk1, wkbk2 As Workbook
Dim RawDataWs, ModifiedDataWs As Worksheet
Dim FindNotificationNumber As Variant
serverfilename = InputBox("Please input name of dummy workbook (file must be open, include .xlsx")
If serverfilename = "" Then Exit Sub
Set wb1 = ThisWorkbook
Set wb2 = Workbooks(serverfilename)
DataSheetName = InputBox("Please enter name of sheet where data is stored")
If DataSheetName = "" Then Exit Sub
Set RawDataWs = wb2.Sheets(DataSheetName)
Set ModifiedDataWs = Sheets.Add(After:=Sheets(Sheets.Count))
Newsheetname = InputBox("Please enter name of new sheet")
ModifiedDataWs.Name = Newsheetname
RawDataWsNotificationlrow = RawDataWs.Range("A" & Rows.Count).End(xlUp).Row
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
ModifiedDataWsNotificationlcolnum = ModifiedDataWs.Cells(1, Columns.Count).End(xlToLeft).Column + 1
ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)
Set RawDataWsNotificationRng = RawDataWs.Range("A2:A" & RawDataWsNotificationlrow)
Set ModifiedDataWsNotificationRng = ModifiedDataWs.Range("F1:" & ModifiedDataWsNotificationlcol & "1")
'------------------------------------TableFeatures---------------------------------------------
With ModifiedDataWs
.Cells(1, "A").Value = "Feature Code"
.Cells(1, "B").Value = "Zone"
.Cells(1, "C").Value = "Sheet"
.Cells(1, "D").Value = "Feature Description"
.Cells(1, "E").Value = "'-TEN OGV KH73126 tolerance"
.Cells(1, "F").Value = "'-TEN OGV KH73126 tolerance"
.Cells(2, "E").Value = "Nominal"
.Cells(2, "F").Value = "Tolerance"
'------------------------------------NotificationColumns---------------------------------------------
For Each cell In RawDataWsNotificationRng
Set ModifiedDataWsNotificationRng = .Range("G1:" & ModifiedDataWsNotificationlcol & "1")
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)
If FindNotificationNumber Is Nothing Then
ModifiedDataWsNotificationlcolnum = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)
Cells(1, ModifiedDataWsNotificationlcol).Value = cell.Value
End If
Next cell
'------------------------------------ZoneandSheetValues---------------------------------------------
Dim RawDataWsZoneRng As Variant: Set RawDataWsZoneRng = RawDataWs.Range("GB2:GB" & RawDataWsNotificationlrow)
Dim ModifiedDataWsZoneRng As Variant: Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B:B")
Dim ModifiedDataWssheetRng As Variant: Set ModifiedDataWssheetRng = ModifiedDataWs.Range("C:C")
Dim RawDataWsExtentRng As Variant: Set RawDataWsExtentRng = RawDataWs.Range("C2:C" & RawDataWsNotificationlrow)
Dim cel As Range
Dim ColumnLetterLRow, LR As Long, ColumnLetter As String, FindSheetinModifiedWs As Variant
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
For Each cell In RawDataWsZoneRng
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)
Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(what:=cell.Value, lookat:=xlWhole)
Set FindSheetinModifiedWs = ModifiedDataWssheetRng.Find(what:=RawDataWs.Cells(cell.Row, "FO"), lookat:=xlWhole)
If RawDataWs.Cells(cell.Row, "H").Value = "CONACC" Then
If FindZoneInModifiedWs Is Nothing Then
LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
Else
If Not FindZoneInModifiedWs Is Nothing And FindSheetinModifiedWs Is Nothing Then
LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
Else
If cell.Value <> vbNullString Then
ColumnLetter = Split(Cells(1, FindNotificationNumber.Column).Address, "$")(1)
If (.Cells(FindZoneInModifiedWs.Row, ColumnLetter) = vbNullString) Then
ColumnLetterLRow = FindZoneInModifiedWs.Row
Else
Set ColumnLetterRow = .Range(ColumnLetter & FindZoneInModifiedWs.Row & ":" & ColumnLetter & "30000").Find(what:="", lookat:=xlWhole)
ColumnLetterLRow = ColumnLetterRow.Row
End If
.Cells(ColumnLetterLRow, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
.Cells(ColumnLetterLRow, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
.Cells(ColumnLetterLRow, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
End If
End If
End If
End If
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
Next cell
'--------------------------Loop through zones and find input all values for zones-----------------
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B3:B" & ModifiedDataWsZoneLrow)
Dim nextrow As Long
For Each cell In ModifiedDataWsZoneRng
For Each cel In RawDataWsZoneRng
If cel.Value = cell.Value Then
Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(What:=RawDataWs.Cells(cel.Row, "A"), lookat:=xlWhole)
Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(What:=cell.Value, lookat:=xlWhole)
If IsEmpty(.Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value) = True Then
.Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value = RawDataWs.Cells(cel.Row, "C").Value
.Cells(FindZoneInModifiedWs.Row, "B").Value = RawDataWs.Cells(cel.Row, "GB").Value
.Cells(FindZoneInModifiedWs.Row, "C").Value = RawDataWs.Cells(cel.Row, "FO").Value
Else
End If
End If
Next cel
Next cell
any ideas would be greatly appreciated! sorry i am new to VBA!
Old Data Sheet
New Sheet
Link to workbook
Link to workbook
Well, that more more complex than i'd thought but here goes:
'type to manage data we use from each row
Type dataRow
notif As Variant
variable As Variant
sht As Variant
zone As Variant
End Type
Sub DoPivot()
Const SEP As String = "<>"
Dim rngData As Range, data, r As Long
Dim colDict As Object, rowDict As Object, comboDict As Object
Dim rd As dataRow, rngOutput As Range, col As Long, rw As Long, k
Dim k2, arr, dictCounts As Object
Dim wsOut As Worksheet, num As Long
Set colDict = CreateObject("scripting.dictionary")
Set rowDict = CreateObject("scripting.dictionary")
Set comboDict = CreateObject("scripting.dictionary")
Set dictCounts = CreateObject("scripting.dictionary")
data = Sheet9.Range("A2:D4788").Value 'source data
Set rngOutput = Sheet9.Range("H1") 'top-left cell for output
Set wsOut = rngOutput.Parent
rngOutput.Resize(5000, 5000).ClearContents
rngOutput.Resize(1, 2).Value = Array("Sheet", "Zone")
col = rngOutput.Column + 2 'start for notification# headers
rw = rngOutput.row + 1
'first pass - assess data variables
For r = 1 To UBound(data, 1)
rd = rowData(data, r)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) 'tracking how many unique combinations of these
comboDict(k) = comboDict(k) + 1 'increment count
'manage column header positions for unique notification numbers
If Not colDict.exists(rd.notif) Then
colDict.Add rd.notif, col 'store the column
rngOutput.EntireRow.Cells(1, col).Value = rd.notif 'add the header
col = col + 1
End If
Next r
'figure out # of rows for each sheet-Zone pair
For Each k In comboDict.keys
arr = Split(k, SEP)
k2 = Join(Array(arr(0), arr(1)), SEP) 'sheet<>zone
'is this more rows than any previous same k2 value?
dictCounts(k2) = Application.Max(dictCounts(k2), comboDict(k))
Next k
'create the row headers
For Each k In dictCounts.keys
num = dictCounts(k)
rowDict(k) = rw 'record start row for each sheet<>zone combo
wsOut.Cells(rw, rngOutput.Column).Resize(num, 2).Value = Split(k, SEP)
dictCounts(k) = 0 'reset so we can track while adding data
rowDict(k) = rw
rw = rw + num
Next k
'last pass - populate the data based on the dictionaries
For r = 1 To UBound(data, 1)
rd = rowData(data, r)
k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) '3-field combo
k2 = Join(Array(rd.sht, rd.zone), SEP) 'row key
wsOut.Cells(rowDict(k2) + (dictCounts(k)), _
colDict(rd.notif)).Value = rd.variable
dictCounts(k) = dictCounts(k) + 1 'increment this unique combo
Next r
End Sub
'populate a Type instance for a given row
Function rowData(data, r As Long) As dataRow
Dim rv As dataRow
rv.notif = IfEmpty(data(r, 1))
rv.variable = IfEmpty(data(r, 2))
rv.sht = IfEmpty(data(r, 3))
rv.zone = IfEmpty(data(r, 4))
rowData = rv
End Function
'substitute EMPTY for zero-length value
Function IfEmpty(v)
IfEmpty = IIf(Len(v) = 0, "EMPTY", v)
End Function
EDIT: if you want to filter out certain rows then you need to modify the loops which iterate over data
For r = 1 To UBound(data, 1)
If data(r, colHere) <> "X" Then '<< add your filter here
rd = rowData(data, r)
'rest of code as before...
End If
Next r
This is the kind of transformation is what I am trying to perform.
For illustration I made this as table. Basically the first three columns should repeat for however many colors are available.
I searched for similar questions but could not find when I want multiple columns to repeat.
I found this code online
Sub createData()
Dim dSht As Worksheet
Dim sSht As Worksheet
Dim colCount As Long
Dim endRow As Long
Dim endRow2 As Long
Set dSht = Sheets("Sheet1") 'Where the data sits
Set sSht = Sheets("Sheet2") 'Where the transposed data goes
sSht.Range("A2:C60000").ClearContents
colCount = dSht.Range("A1").End(xlToRight).Column
'// loops through all the columns extracting data where "Thank" isn't blank
For i = 2 To colCount Step 2
endRow = dSht.Cells(1, i).End(xlDown).Row
For j = 2 To endRow
If dSht.Cells(j, i) <> "" Then
endRow2 = sSht.Range("A50000").End(xlUp).Row + 1
sSht.Range("A" & endRow2) = dSht.Range("A" & j)
sSht.Range("B" & endRow2) = dSht.Cells(j, i)
sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1)
End If
Next j
Next i
End Sub
I tried changing step 2 to 1 and j to start from 4.
Another example with two varied sets:
Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the columns to be unpivoted)
Test sub:
Sub Tester()
Dim p
'get the unpivoted data as a 2-D array
p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _
3, False, False)
With Sheets("Sheet1").Range("H1")
.CurrentRegion.ClearContents
.Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
End With
'EDIT: alternative (slower) method to populate the sheet
' from the pivoted dataset. Might need to use this
' if you have a large amount of data
'Dim r As Long, c As Long
'For r = 1 To Ubound(p, 1)
'For c = 1 To Ubound(p, 2)
' Sheets("Sheet2").Cells(r, c).Value = p(r, c)
'Next c
'Next r
End Sub
UnPivot function - should not need any modifications:
Function UnPivotData(rngSrc As Range, fixedCols As Long, _
Optional AddCategoryColumn As Boolean = True, _
Optional IncludeBlanks As Boolean = True)
Dim nR As Long, nC As Long, data, dOut()
Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
Dim outRows As Long, outCols As Long
data = rngSrc.Value 'get the whole table as a 2-D array
nR = UBound(data, 1) 'how many rows
nC = UBound(data, 2) 'how many cols
'calculate the size of the final unpivoted table
outRows = nR * (nC - fixedCols)
outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
'resize the output array
ReDim dOut(1 To outRows, 1 To outCols)
'populate the header row
For c = 1 To fixedCols
dOut(1, c) = data(1, c)
Next c
If AddCategoryColumn Then
dOut(1, fixedCols + 1) = "Category"
dOut(1, fixedCols + 2) = "Value"
Else
dOut(1, fixedCols + 1) = "Value"
End If
'populate the data
rOut = 1
For r = 2 To nR
For cat = fixedCols + 1 To nC
If IncludeBlanks Or Len(data(r, cat)) > 0 Then
rOut = rOut + 1
'Fixed columns...
For c = 1 To fixedCols
dOut(rOut, c) = data(r, c)
Next c
'populate unpivoted values
If AddCategoryColumn Then
dOut(rOut, fixedCols + 1) = data(1, cat)
dOut(rOut, fixedCols + 2) = data(r, cat)
Else
dOut(rOut, fixedCols + 1) = data(r, cat)
End If
End If
Next cat
Next r
UnPivotData = dOut
End Function
Here is one way (fastest?) using arrays. This approach is better that the linked question as it doesn't read and write to/from range objects in a loop. I have commented the code so you shouldn't have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim ThisAr As Variant, ThatAr As Variant
Dim Lrow As Long, Col As Long
Dim i As Long, k As Long
Set wsThis = Sheet1: Set wsThat = Sheet2
With wsThis
'~~> Find Last Row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find total value in D,E,F so that we can define output array
Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))
'~~> Store the values from the range in an array
ThisAr = .Range("A2:F" & Lrow).Value
'~~> Define your new array
ReDim ThatAr(1 To Col, 1 To 4)
'~~> Loop through the array and store values in new array
For i = LBound(ThisAr) To UBound(ThisAr)
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
'~~> Check for Color 1
If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)
'~~> Check for Color 2
If ThisAr(i, 5) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 5)
End If
'~~> Check for Color 3
If ThisAr(i, 6) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 6)
End If
Next i
End With
'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value
'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub
SHEET1
SHEET2
The addition of the LET function allows for this non-VBA solution.
=LET(data,B3:F6,
dataRows,ROWS(data),
dataCols,COLUMNS(data),
rowHeaders,OFFSET(data,0,-1,dataRows,1),
colHeaders,OFFSET(data,-1,0,1,dataCols),
dataIndex,SEQUENCE(dataRows*dataCols),
rowIndex,MOD(dataIndex-1,dataRows)+1,
colIndex,INT((dataIndex-1)/dataRows)+1,
FILTER(CHOOSE({1,2,3}, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)), index(data,rowIndex,colIndex)<>""))
Below is a custom function I wrote for such things (demo video I posted on YouTube). A few differences from other answers:
The custom function allows for more than one axis in columns. As shown below, the column axis has Currency and Time.
Row axis does not need to be directly next to the data range.
One can specify the entire row as the column axis or the entire column to specify the row axis. See formula used as example below.
So with this data set:
And entering this as the formula:
=unPivotData(D4:G7,2:3,B:C)
an output of this:
Function unPivotData(theDataRange As Range, theColumnRange As Range, theRowRange As Range, _
Optional skipZerosAsTrue As Boolean, Optional includeBlanksAsTrue As Boolean)
'Set effecient range
Dim cleanedDataRange As Range
Set cleanedDataRange = Intersect(theDataRange, theDataRange.Worksheet.UsedRange)
'tests Data ranges
With cleanedDataRange
'Use intersect address to account for users selecting full row or column
If .EntireColumn.Address <> Intersect(.EntireColumn, theColumnRange).EntireColumn.Address Then
unPivotData = "datarange missing Column Ranges"
ElseIf .EntireRow.Address <> Intersect(.EntireRow, theRowRange).EntireRow.Address Then
unPivotData = "datarange missing row Ranges"
ElseIf Not Intersect(cleanedDataRange, theColumnRange) Is Nothing Then
unPivotData = "datarange may not intersect column range. " & Intersect(cleanedDataRange, theColumnRange).Address
ElseIf Not Intersect(cleanedDataRange, theRowRange) Is Nothing Then
unPivotData = "datarange may not intersect row range. " & Intersect(cleanedDataRange, theRowRange).Address
End If
'exits if errors were found
If Len(unPivotData) > 0 Then Exit Function
Dim dimCount As Long
dimCount = theColumnRange.Rows.Count + theRowRange.Columns.Count
Dim aCell As Range, i As Long, g As Long
ReDim newdata(dimCount, i)
End With
'loops through data ranges
For Each aCell In cleanedDataRange.Cells
With aCell
If .Value2 = "" And Not (includeBlanksAsTrue) Then
'skip
ElseIf .Value2 = 0 And skipZerosAsTrue Then
'skip
Else
ReDim Preserve newdata(dimCount, i)
g = 0
'gets DimensionMembers members
For Each gcell In Union(Intersect(.EntireColumn, theColumnRange), _
Intersect(.EntireRow, theRowRange)).Cells
newdata(g, i) = IIf(gcell.Value2 = "", "", gcell.Value)
g = g + 1
Next gcell
newdata(g, i) = IIf(.Value2 = "", "", .Value)
i = i + 1
End If
End With
Next aCell
unPivotData = WorksheetFunction.Transpose(newdata)
End Function
Dim rOriginal As Range 'row records in the lookup sheet (cList = Sheet2)
Dim rFind As Range 'row record in the target sheet (TotalList = Sheet1)
Dim rTableOriginal As Range 'row records in the lookup sheet (cList = Sheet2)
Dim rTableFind As Range 'row record in the target sheet (TotalList = Sheet1)
Dim shOriginal As Worksheet
Dim shFind As Worksheet
Dim booFound As Boolean
Dim shMix As Worksheet
'Initiate all used objects and variables
Set shOriginal = ThisWorkbook.Sheets("Male")
Set shFind = ThisWorkbook.Sheets("Female")
Set shMix = ThisWorkbook.Sheets("Mix")
Set rTableOriginal = shOriginal.Range(shOriginal.Rows(2), shOriginal.Rows(shOriginal.Rows.count).End(xlUp))
Set rTableFind = shFind.Range(shFind.Rows(2), shFind.Rows(shFind.Rows.count).End(xlUp))
booFound = False
For Each rOriginal In rTableOriginal.Rows
booFound = False
For Each rFind In rTableFind.Rows
'Check if the E and F column contain the same information
If rOriginal.Cells(1, 1) = rFind.Cells(1, 1) And rOriginal.Cells(1, 13) = rFind.Cells(1, 13) And rOriginal.Cells(1, 11) = rFind.Cells(1, 11) Then
'The record is found so we can search for the next one
booFound = True
GoTo FindNextOriginal 'Alternatively use Exit For
End If
Next rFind
'In case the code is extended I always use a boolean and an If statement to make sure we cannot
'by accident end up in this copy-paste-apply_yellow part!!
If booFound = True Then
'If not found then copy form the Original sheet ...
rOriginal.Copy
rFind.Copy
'... paste on the Find sheet and apply the Yellow interior color
With shMix.Rows(Mix.Rows.count + 1)
.PasteSpecial
End With
End If
FindNextOriginal:
Next rOriginal
So I have searched the site and came up with the codes above. But it still doesn't seem to work. My objective is to match 3 columns on sheet "Male" with another 3 columns on sheet "Female" if it matches, the code will then copy the row on both sheets and paste it on sheet "Mix". The columns I am trying to compare are columns A , K and M respectively.
Example:
Column A | Column K | Column M
1/1/2000 | 20 | 1
2/1/2000 | 21 | 4
3/1/2000 | 22 | 5
1/1/2000 | 20 | 1
4/1/2000 | 24 | 3
6/1/2000 | 25 | 6
Copy row 1 on both worksheet and paste it in sheet "Mix"
I've found that the most efficient method for something like a three column match is often a Scripting.Dictionary object that comes with its own unique reference key index. Temporary 'helper' columns that concatenate the three values for a single comparison are another option but 'in-memory' evaluation is usually the most efficient.
Sub three_col_match_and_copy()
Dim c As Long, v As Long, w As Long, vTMPs As Variant, itm As String, vVALs() As Variant, k As Variant
Dim dTMPs As Object '<~~ late binding use As New Scipting.Dictionary for early binding
Dim dMIXs As Object '<~~ late binding use As New Scipting.Dictionary for early binding
'late binding of the dictionary object
Set dTMPs = CreateObject("Scripting.Dictionary")
Set dMIXs = CreateObject("Scripting.Dictionary")
'grab all of Males into variant array
With Worksheets("male")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
vTMPs = .Cells.Value2
End With
End With
End With
'build first dictionary
For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
If Not dTMPs.exists(Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203))) Then
itm = "gonna be discarded in any event"
dTMPs.Add Key:=Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203)), _
Item:=itm
End If
Next v
'grab all of Females into reused variant array
With Worksheets("female")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
vTMPs = .Cells.Value2
End With
End With
End With
'save for later
c = UBound(vTMPs, 2)
'build second dictionary on matches
For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
If dTMPs.exists(Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203))) Then
itm = vTMPs(v, 1)
For w = LBound(vTMPs, 2) + 1 To UBound(vTMPs, 2)
itm = Join(Array(itm, vTMPs(v, w)), ChrW(8203))
Next w
dMIXs.Add Key:=Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203)), _
Item:=itm
End If
Next v
'continue if there is something to xfer
If CBool(dMIXs.Count) Then
'create variant array of the matches from the dictionary
v = 1
ReDim vVALs(1 To dMIXs.Count, 1 To UBound(vTMPs, 2))
Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1)
Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2)
For Each k In dMIXs
vTMPs = Split(dMIXs.Item(k), ChrW(8203))
For w = LBound(vTMPs) To UBound(vTMPs)
vVALs(v, w + 1) = vTMPs(w)
Next w
v = v + 1
Debug.Print dMIXs.Item(k)
Next k
'put the matched rows into the Mix worksheet
With Worksheets("mix")
With .Cells(1, 1).CurrentRegion
With .Resize(UBound(vVALs, 1), UBound(vVALs, 2)).Offset(1, 0)
.Cells = vVALs
End With
End With
End With
End If
dTMPs.RemoveAll: Set dTMPs = Nothing
dMIXs.RemoveAll: Set dMIXs = Nothing
End Sub
I have used raw values in the transfer. You will most likely have to correctly format things like date values in the Mix worksheet but that should not be a problem for a 'programming enthusiast'.
Kindly try the following code
Sub Test()
Dim lastr As Long
Dim lastrmale As Long
Dim lastrfemale As Long
Dim lastrmix As Long
Dim malesheet As Worksheet
Dim Femalesheet As Worksheet
Dim mixsheet As Worksheet
Dim i As Long
Set malesheet = Worksheets("Male")
Set Femalesheet = Worksheets("Female")
Set mixsheet = Worksheets("mix")
lastrmale = malesheet.Range("A" & malesheet.Range("A1").SpecialCells(xlLastCell).Row + 1).End(xlUp).Row
lastrfemale = Femalesheet.Range("A" & Femalesheet.Range("A1").SpecialCells(xlLastCell).Row + 1).End(xlUp).Row
lastr = WorksheetFunction.Min(lastrmale, lastrfemale)
lastrmix = 2
For i = 2 To lastr
If (malesheet.Range("A" & i).Value = Femalesheet.Range("A" & i).Value) And (malesheet.Range("K" & i).Value = Femalesheet.Range("K" & i).Value) And (malesheet.Range("M" & i).Value = Femalesheet.Range("M" & i).Value) Then
malesheet.Rows(i & ":" & i).Copy
mixsheet.Range("A" & lastrmix).PasteSpecial xlPasteAll
lastrmix = lastrmix + 1
Femalesheet.Rows(i & ":" & i).Copy
mixsheet.Range("A" & lastrmix).PasteSpecial xlPasteAll
lastrmix = lastrmix + 1
End If
Next
End Sub