I would like to transform my report into this form shown in the picture !
enter image description here
I've tried to use Offset function or dynamic assigning, but when I used to try these methods , the first row of my report was deleted.
Here is the code
Sub create_report()
Dim itemWs As Worksheet, offerWs As Worksheet, testWs As Worksheet
Dim itemLastRow As Long, offerLastRow As Long
Dim offerLastCol As Long, itemLastCol As Long
Dim dataRng As Range
Set itemWs = ThisWorkbook.Worksheets("nn_rfx_compare_per_lot")
Set offerWs = ThisWorkbook.Worksheets("Offers")
Set testWs = ThisWorkbook.Worksheets("Testowy")
itemLastRow = itemWs.Range("A" & Rows.Count).End(xlUp).Row
offerLastRow = offerWs.Range("A" & Rows.Count).End(xlUp).Row
offerLastCol = offerWs.Cells(1, Columns.Count).End(xlToLeft).Column
itemLastCol = itemWs.Cells(1, Columns.Count).End(xlToLeft).Column
Set dataRng = testWs.Range("I3:AF" & 4)
'For x = 2 To 7
'On Error Resume Next
'itemWs.Range("I" & x).Value = Application.WorksheetFunction.VLookup(itemWs.Range("C" & x).Value & itemWs.Range("B" & x).Value, dataRng, 3, 0)
'Next x
Sheets("Testowy").Range(Sheets("Testowy").Cells(offerLastCol - 1, 1), Sheets("Testowy").Cells(itemLastRow + 4, itemLastCol)) = _
Sheets("nn_rfx_compare_per_lot").Range(Sheets("nn_rfx_compare_per_lot").Cells(1, 1), Sheets("nn_rfx_compare_per_lot").Cells(itemLastRow, itemLastCol)).Value
Sheets("Testowy").Range(Sheets("Testowy").Cells(1, itemLastCol + 1), Sheets("Testowy").Cells(offerLastCol - 1, offerLastRow + itemLastCol)) = _
WorksheetFunction.Transpose(Sheets("Offers").Range(Sheets("Offers").Cells(1, 2), Sheets("Offers").Cells(offerLastRow, offerLastCol)))
Dim lastTestCol As Long
lastTestCol = testWs.Cells(1, Columns.Count).End(xlToLeft).Column
Dim ColumnLetter As String
For Row = 6 To 11
For Col = 9 To lastTestCol
On Error Resume Next
testWs.Cells(Row, Col).Value = Application.WorksheetFunction.Index(testWs.Cells( _
5, Col), Application.WorksheetFunction.Match(testWs.Cells(Row, 3).Value, testWs.Cells(3, Col), 0))
Next Col
Next Row
For Cl = 9 To lastTestCol
On Error Resume Next
testWs.Cells(5, Cl) = ""
Next Cl
End Sub
Related
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
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 have different test dates and times that can be up to about 100 tests each time point. I received the data that was only a single column that consists of thousands of rows, which should have been delivered in a matrix type grid.
I have only copied a sample, which has 6 time points and up to 4 tests each. I need Excel to "recognize" when there is only a date/time in a cell, then copy that cell to the next date/time to paste in a new sheet and column.
Eventually, I was hoping to also have the Title of the test separated from the results. However, if this is not plausible without knowing the name of every test, I can skip it. This is the data I start with:
Title
01/02/2010 0:03
Ounces: 10.87
Concentration: 6.89 (L)
Expiration Date: 11/2/2019 5:47:00
01/06/2011 2:06
Ounces: 18.09
Concentration: 10.7 (H)
Expiration Date: 11/2/2019 5:47:00
Other: Resampled
01/06/2011 2:06
Ounces: 12.87
Concentration: 10.9 (H)
Expiration Date: 11/2/2019 5:47:00
Other: 2nd Sample
09/15/2012 7:07
Ounces: 8.53
Concentration: 9.72
Expiration Date: 12/5/2019 4:45:00
05/02/2013 15:52
Ounces: 11.62
Concentration: 8.42
05/09/2017 1:45
Ounces: 9.34
Concentration: 8.98
I created the following Excel VBA, but am still new at programming, especially loops within loops, so I could not figure out how to create the offset that is dynamic enough to both select the right cells, but to copy them over to a new column. I also have redundancy within the code.
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long
sSheet = ActiveSheet.Name
Sheets.Add
dSheet = ActiveSheet.Name
With Worksheets("Sheet1")
' All Data is in Column A
NumberofTasks = .Cells(.Rows.Count, "A").End(xlUp).Row
For x = 1 To NumberofTasks
Sheets(sSheet).Activate
If IsDate(.Range("A" & x).Value) Then '<-- check if current cell at Column A is Date
Range(Cells(x, 1), Cells(x, 1).Offset(4, 0)).Select
Selection.Copy
Sheets(dSheet).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
ActiveCell.Offset(1, 0).Select
End If
Next x
End With
End Sub
This is what I hoped would happen (but on a much larger scale):
However, the offset places another date in another cell with the current code. Thank you for any help you can provide me.
There are many ways to skin a cat. Here is one way using arrays which is much much faster than looping through the range
Worksheet:
I am for the sake of coding, assuming that the data is in Sheet1 and looks like below
Logic:
Store the data from the worksheet in an array; Let's call it InputArray
Create an output array for storing data; Let's call it OutputArray
Loop through InputArray and find the date and then find the rest of the records. store in OutputArray
direct the output from OutputArray to the relevant worksheet.
Code:
Option Explicit
Sub Sample()
Dim InputArray As Variant
Dim ws As Worksheet
Dim i As Long
Dim recCount As Long
Dim lRow As Long
Dim OutputArray() As String
'~~> Set relevant input sheet
Set ws = Sheet1
With ws
'~~> Find Last Row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Store col A in array
InputArray = .Range("A1:A" & lRow).Value
'~~> Find Total number of records
For i = LBound(InputArray) To UBound(InputArray)
If IsDate(InputArray(i, 1)) Then recCount = recCount + 1
Next i
'~~> Create an array for output
ReDim OutputArray(1 To 5, 1 To recCount + 1)
recCount = 2
'~~> Fill Col A of output array
OutputArray(1, 1) = "Title"
OutputArray(2, 1) = "Ounces"
OutputArray(3, 1) = "Concentration"
OutputArray(4, 1) = "Expiration Date"
OutputArray(5, 1) = "Other"
'~~> Loop through input array
For i = UBound(InputArray) To LBound(InputArray) Step -1
If IsDate(InputArray(i, 1)) Then '< Check if date
OutputArray(1, recCount) = InputArray(i, 1)
'~~> Check for Ounces and store in array
If i + 1 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 1, 1)), 2)) = "OU" _
Then OutputArray(2, recCount) = Trim(Replace(InputArray(i + 1, 1), "Ounces:", ""))
'~~> Check for Concentration and store in array
If i + 2 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 2, 1)), 2)) = "CO" _
Then OutputArray(3, recCount) = Trim(Replace(InputArray(i + 2, 1), "Concentration:", ""))
'~~> Check for Expiration Date and store in array
If i + 3 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 3, 1)), 2)) = "EX" _
Then OutputArray(4, recCount) = Trim(Replace(InputArray(i + 3, 1), "Expiration Date:", ""))
'~~> Check for Other and store in array
If i + 4 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 4, 1)), 2)) = "OT" _
Then OutputArray(5, recCount) = Trim(Replace(InputArray(i + 4, 1), "Other:", ""))
recCount = recCount + 1
End If
Next i
End With
'~~> Output it to relevant sheet
Sheet2.Range("A1").Resize(5, recCount - 1).Value = OutputArray
End Sub
Output:
I think here is better way to do it using Range.Find
Assuming the Data is in 1st Column of Sheet1 ie. Column A
In Demo the Expiration Date is not right, I have corrected that in the Code.
Try this code:
Sub TP()
Dim wk As Worksheet: Set wk = ThisWorkbook.Worksheets("Sheet1")
Dim lr As Long: lr = wk.Cells(wk.Rows.Count, "A").End(xlUp).row
Dim rng As Range
Dim i As Long
Dim j As Long
j = 4
For i = 3 To lr
Set rng = wk.Range(Cells(i, 1), Cells(i, 1).End(xlDown))
wk.Cells(2, j).Value = rng.Cells(1, 1).Value
Set fnd = rng.Find("Ounces")
If Not fnd Is Nothing Then wk.Cells(3, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Concentration")
If Not fnd Is Nothing Then wk.Cells(4, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Expiration")
If Not fnd Is Nothing Then wk.Cells(5, j).Value = Right(fnd.Value, Len(fnd.Value) - Len(Split(fnd.Value, ":")(0)) - 2)
Set fnd = Nothing
Set fnd = rng.Find("Other")
If Not fnd Is Nothing Then wk.Cells(6, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
i = Cells(i, 1).End(xlDown).row + 1
j = j + 1
Next
End Sub
Demo:
May try something like this. Original code was modified and organized to complete the task intended. It takes cares if the other parameters of the test result are not organised in sequence as shown, blank row in between the parameters, no blank row between test results and or missing parameters. It only considers parameters found between rows of two test titles (date time). Takes only 0.5 seconds to process 200 test results from more than 1 K rows.
Option Explicit
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long, LastRow As Long, Xval As Variant
Dim srcWs As Worksheet, trgWs As Worksheet
Dim tm As Double
tm = Timer
Set srcWs = ThisWorkbook.ActiveSheet
Set trgWs = ThisWorkbook.Worksheets.Add
trgWs.Cells(1, 1).Value = "Title"
trgWs.Cells(2, 1).Value = "Ounces:"
trgWs.Cells(3, 1).Value = "Concentration:"
trgWs.Cells(4, 1).Value = "Expiration Date:"
trgWs.Cells(5, 1).Value = "Other:"
With srcWs
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
NumberofTasks = 0
x = 1
Do While x <= LastRow
Xval = .Cells(x, 1).Value
If IsDate(Xval) Then
NumberofTasks = NumberofTasks + 1
trgWs.Cells(1, NumberofTasks + 1).Value = .Range("A" & x).Value
ElseIf VarType(Xval) = vbString And NumberofTasks > 0 Then
Xval = Trim(LCase(Xval))
If InStr(1, Xval, "ounces:") > 0 Then
trgWs.Cells(2, NumberofTasks + 1).Value = Trim(Replace(Xval, "ounces:", ""))
ElseIf InStr(1, Xval, "concentration:") > 0 Then
trgWs.Cells(3, NumberofTasks + 1).Value = Trim(Replace(Xval, "concentration:", ""))
ElseIf InStr(1, Xval, "expiration date:") > 0 Then
trgWs.Cells(4, NumberofTasks + 1).Value = Trim(Replace(Xval, "expiration date:", ""))
ElseIf InStr(1, Xval, "other:") > 0 Then
trgWs.Cells(5, NumberofTasks + 1).Value = Trim(Replace(Xval, "other:", ""))
End If
End If
x = x + 1
Loop
End With
'Debug.Print "Seconds "; Timer - tm
End Sub
Tested to produce the result like
this
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