I have two columns A and B in same excel sheet. I am trying that if in Column B two values matches then it should copy related value A in same row.
For e.g
Table
Column A Column B
xyz 1
abc 1
pqr 1
eee 2
qqq 3
www 4
oop 5
Desierd Output
column A Column B
xyz,abc,pqr 1
eee 2
qqq 3
www 4
oop 5
You could probably use a User Defined Function (aka UDF) for this. Put this into a module sheet.
Public Function conditional_concat_strs(rSTRs As Range, rCRITs As Range, rCRIT As Range, Optional sDELIM As String = ", ")
Dim c As Long, sTMP As String
Set rSTRs = rSTRs.Cells(1, 1).Resize(rCRITs.Rows.Count, rCRITs.Columns.Count)
For c = 1 To rCRITs.Cells.Count
If rCRITs(c).Value2 = rCRIT Then _
sTMP = sTMP & rSTRs(c).Value & sDELIM
Next c
conditional_concat_strs = Left(sTMP, Application.Max(Len(sTMP) - Len(sDELIM), 0))
End Function
Use like any native worksheet function.
You can also use this one:
Public Sub combine()
Dim row, result, lastRow As Integer
Dim isExist As Boolean
With Sheets("sheetname")
'get the last use row
lastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).row
'Loop from row 1 to last row
For row = 1 To lastRow Step 1
'set the start row for result.
result = 1
'Reset flag
isExist = False
'Loop result count column until blank
Do While .Range("F" & result) <> ""
'check count
If .Range("B" & row) = .Range("F" & result) Then
isExist = True
'If old, combine
.Range("E" & result) = .Range("E" & result) & "," & .Range("A" & row)
Exit Do
End If
'increase row
result = result + 1
Loop
'If new, add new record
If Not isExist Then
.Range("E" & result) = .Range("A" & row)
.Range("F" & result) = .Range("B" & row)
End If
Next row
End With
End Sub
Here, testing evidence for my code:
I used column A & B as input and column E & F as output.
If there is any problem, let me know.
There's a formula solution for this as well (with helper columns):
Assuming data is column A:B ...
In C1 write this formula: =IF(A1<>A2,B2,D1&","&B2)
In D1 write this formula: =IF(A2<>A3,A2,"")
Filter on column D for blanks and then deleted the visible cells.
Related
I have a table with columns A, B and C, all values in columns are in ascending order. Column A has serial number, column B has names and column C has quantities.
When I enter a name for example in cell L2 and in cell M2 required quantity let's say 540 the macro should search name from cell L2 in column B and sum all values for that name until sum is matched with value from cell M2. When sum is matched, copy(return) all serial numbers in column A from that sum range in column N.
I manually made an example how it should look.
I made the same question on another forum but no answers (https://www.mrexcel.com/board/threads/reverse-sumif-return-column-values-based-on-sum-criteria.1179552/)
See how this works for you:
Sub GetSerialNo()
Dim ws As Worksheet, lRowInput As Long, lRowResults As Long, i As Long
Dim arr, SName As String, SQuantity As Double, CurQuantity As Double
Dim MatchList(), MatchCount As Long
Set ws = Sheets("Blanko List") 'Your sheet name
lRowInput = ws.Range("A" & Rows.Count).End(xlUp).Row 'Last row of data
lRowResults = ws.Range("N" & Rows.Count).End(xlUp).Row 'Last row of previous results
arr = ws.Range("A2:C" & lRowInput).Value 'Populate the array
SName = ws.Range("L2").Value 'Search name
SQuantity = ws.Range("M2").Value 'Search Quantity
CurQuantity = 0 'Ensure these 2 values are 0
MatchCount = 0
For i = 1 To UBound(arr, 1) 'Loop from row 1 to last row
If arr(i, 2) = SName Then 'If name = search name
If arr(i,3) > 0 Then 'New line to skip quantities of 0
CurQuantity = CurQuantity + arr(i, 3) 'add quantity
MatchCount = MatchCount + 1 'Add match count
ReDim Preserve MatchList(1 To MatchCount) 'Resize the matchlist array to add a new row
MatchList(UBound(MatchList)) = arr(i, 1) 'Add the name to new row of matchlist
If CurQuantity >= SQuantity Then Exit For 'If the quantity is equal or greater than search quantity then exit the loop
End if
End If
Next i
ws.Range("N2:N" & lRowResults + 1).ClearContents 'Clear previous results list
ws.Range("N2").Resize(UBound(MatchList)).Value = Application.Transpose(MatchList) 'Dump new results into column N
If CurQuantity < SQuantity Then
MsgBox "The available quantity is less than the desired quantity." & vbCr & vbCr & _
"Desired: " & SQuantity & vbCr & "Available: " & CurQuantity & vbCr & _
"Difference: " & CurQuantity - SQuantity, vbExclamation, "Missing Quantities"
End If
End Sub
I've added comments to each line so you can hopefully follow along to what it is doing.
I also just added the detection if the available quantity is less than the desired. You can obviously change exactly what the message box says to what you want.
In Column A of Sheet 1, I have a list of serial numbers which contain duplicates. I want to delete all duplicates and instead come up with a history column which captures all the information of the adjacent cells with regards to that serial number. The logic of my script goes like this: 1) Filter all distinct serial numbers into a new sheet 2) For each cell in new sheet, find all matching cells in sheet 1 3) If they match then copy adjacent columns information and create an new column with new matching information 4) The more serial duplicates are, the bigger the "history" cell of that serial number is going to have
Here is a screenshot of what I'm trying to do:
https://imgur.com/a/KEn0RIP
When I use "FindPN.Interior.ColorIndex = 3", the program does fine, finding all the 1's in the column and coloring them red. I just want to copy each the 3 cells' values that are adjacent to each '1' in Column A. I have used a Dictionary to create a dynamic variable to spit out the final cell that I want, but when I run the program, I am having problems understanding how the place the variables in the FindNext loop to spit out each different B2, C2, and D2.
Sub FindPN1() 'simplified script finding all the 1's in Sheet 1
Dim I, J, K, L, Atotal As Integer
Dim FindPN, FoundPN As Range
Dim UniqueValue As Range
Dim strStatus, strDate, strComments As Object
Atotal = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
With Sheets(1)
For I = 2 To Atotal
Set FindPN = Sheets(1).Columns(1).Find(1, LookIn:=xlValues)
If Not FindPN Is Nothing Then
Set FoundPN = FindPN
Set strStatus = CreateObject("Scripting.Dictionary")
For J = 1 To Atotal
strStatus(J) = Range("B" & I).Value
Next
Set strComments = CreateObject("Scripting.Dictionary")
For K = 1 To Atotal
strComments(K) = Range("C" & I).Value
Next
Set strDate = CreateObject("Scripting.Dictionary")
For L = 1 To Atotal
strDate(L) = Range("D" & I).Value
Next
Range("A15").Value = strDate(1)
'FindPN.Interior.ColorIndex = 3
Do
Set FindPN = .Columns(1).FindNext(After:=FindPN)
If Not FindPN Is Nothing Then
strStatus(J) = Range("B" & I).Value
strComments(K) = Range("C" & I).Value
strDate(L) = Range("D" & I).Value
'FindPN.Interior.ColorIndex = 3
Range("B15").Value = strDate(3)
If FindPN.Address = FoundPN.Address Then Exit Do
Else
Exit Do
End If
Loop
End If
Next
End With
The problem I am having is not knowing how to store my variables and having them spit out the 'History' Cell the way that I want. I have been practicing by going inside the loop to see where each variable gets defined but it seems like the strDate is always spitting out the date corresponding to the first 1.
You can make this much simpler - use a single dictionary and loop over the rows.
Add new Id's (and their "history" value) where they don't exist: if an id is already in the dictionary then append the new piece of history to the existing value.
When done, loop over the dictionary and write out the keys and the values.
Sub CombineRows()
Dim i As Long, h, k, lastRow As Long
Dim dict As Object, wsSrc As Worksheet
Set wsSrc = Sheets(1)
lastRow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
With Sheets(1).Rows(i)
k = .Cells(1).Value
h = .Cells(2).Value & "|" & _
.Cells(4).Text & "|" & _
.Cells(3).Value
If dict.exists(k) Then
dict(k) = dict(k) & vbLf & h
Else
dict.Add k, h
End If
End With
Next i
DumpDict dict, Sheets(2).Range("A1")
End Sub
'write out dictionary content starting at "rng"
Sub DumpDict(dict As Object, rng As Range)
Dim c As Range, k
Set c = rng.Cells(1)
For Each k In dict.keys
c.Value = k
c.Offset(0, 1).Value = dict(k)
Set c = c.Offset(1, 0)
Next k
End Sub
I am very new to coding with it, and what appears below probably looks quite horrible.
What this code currently does is do an instr search for all 3 required values appearing in a single, and absolutely defined (for test purposes), row of another table, in a separate worksheet. Copies the A cell value from that row, pastes it into the cell next to the source table row, currently being searched, and colour codes it with a green fill.
What I want it to do, is be aware that there is a whole other table of data in the other worksheet, and have it search row by row for all 3 required values matching in a given row.
Once it gets an exact hit, I want it to output the A cell value for the row that has been confirmed to be a match of all 3 required values.
The table in the other sheet is dynamic, in that it increases or decreases in total number of rows day be day.
Is anyone kind enough to be able to help me with this?
Now, here is my novice mishmash of code:
Private Sub Match_Click()
Dim i As Integer, row As Integer, narrative1 As String, transDate As Date,
amount As Double, result As String
row = 2
i = 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Do While Cells(i, 1).Value <> ""
If narrative1 > "" Then
If InStr(1, UCase(Worksheets("Sheet1").Range("D22")), UCase(narrative1)) And
InStr(1, Worksheets("Sheet1").Range("B22"), transDate) And InStr(1,
Worksheets("Sheet1").Range("H22"), amount) Then
result = Worksheets("Sheet1").Range("A3").Value
Else
result = ""
End If
End If
i = i + 1
If Worksheets("Sheet2").Range("A" & row).Value = "" Then result = ""
Worksheets("Sheet2").Range("K" & row).Value = result
If result <> "" Then Worksheets("Sheet2").Range("K" & row).Interior.Color =
RGB(198, 224, 180)
If Worksheets("Sheet2").Range("A" & row).Value = "" Then
Worksheets("Sheet2").Range("K" & row).Interior.ColorIndex = xlNone
row = row + 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Loop
End Sub
I think the following code will do what you expect, I've commented it to let you know what its doing (I haven't tested it, but I'm pretty sure it will do the job):
Private Sub Match_Click()
Dim i As Long 'These should be Long instead of Integer, as Excel has more cells than Integer has values.
Dim row As Long
Dim LastRow As Long
Dim LastRow2 As Long
Dim narrative1 As String
Dim transDate As String
Dim amount As Double
Dim result As String
Dim val1 As Integer
Dim val2 As Integer
Dim val3 As Integer
LastRow2 = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet2
LastRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet1
For i = 1 To LastRow2 'loop from row 1 to last on Sheet2
narrative1 = Worksheets("Sheet2").Range("D" & i) 'get the variables to compare
transDate = Worksheets("Sheet2").Range("B" & i)
amount = Worksheets("Sheet2").Range("J" & i)
For x = 1 To LastRow ' loop through row 1 to last on Sheet1
If narrative1 <> "" Then
val1 = InStr(Worksheets("Sheet1").Cells(x, 4).Value, narrative1) 'number 4 represents column D
val2 = InStr(Worksheets("Sheet1").Cells(x, 2).Value, transDate) 'number 2 represents column B
val3 = InStr(Worksheets("Sheet1").Cells(x, 8).Value, amount) 'number 8 represents column H
If val1 > 0 And val2 > 0 And val3 > 0 Then 'if all three have been found
result = Worksheets("Sheet1").Cells(x, 1).Value 'get result
Worksheets("Sheet2").Range("K" & LastRow2 + 1).Value = result 'paster result into next free row on Sheet2 column K
If Worksheets("Sheet2").Cells(x, 1).Value <> "" Then Worksheets("Sheet2").Range("K" & LastRow2 + 1).Interior.ColorIndex = 4
Else
result = ""
End If
End If
Next x
Next i
End Sub
The group column in my table contains a value as either 1 or 2 . I want to copy the row with value as 1 to Sheet2 and rows with values as 2 to sheet3 using a button. Also it should show error message if cells are left blank or if value is neither 1 nor 2.
Roll no meter width group
112 150 130 1
Since i am new to coding i have following this approach
check if the cell is empty and generate an error message
check if the cell contains value other than 1 or 2 and generate error message
finally copy the row with values as 1 to Sheet2 and rest all in sheet3
I need help in doing this is an effective way. As i have to keep the size of file down
enter code here
Private Sub CommandButton2_Click()
Dim i As Integer
p = Sheet1.Range("l1").Value 'no. of filled cells in the range
Application.DisplayAlerts = False
Sheet1.Activate
''checking if the range is empty
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value = "" Then
MsgBox ("PLEASE ENTER THE SHRINKAGE GROUP FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
'' checking if the range contains values other than 1 or 2
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value <> 1 And Sheet1.Range("l" & i).Value <> 2 Then
MsgBox ("SHADE GROUP DOES NOT EXIST FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
' sort based on the group
Range("a29:L300").Sort _
Key1:=Range("l29"), Header:=xlYes
'count the number of rolls in group 1
Dim x, y As Long
Dim a, b As Integer
x = Range("L" & Rows.Count).End(xlUp).Row
If x < 29 Then x = 29
a = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 1) + 28
Range("M1").Value = a
' count the number of rolls in group 2
y = Range("L" & Rows.Count).End(xlUp).Row
If y < 29 Then y = 29
b = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 2)
Range("n1").Value = b
'' copying groupwise to different sheet
Sheet1.Range("a29", "l" & a).Copy
Sheet2.Range("a5").PasteSpecial xlPasteAll
Sheet2.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
'' copying group 2
Sheet1.Range("a" & a + 1, "l" & a + b).Copy
Sheet5.Range("a5").PasteSpecial xlPasteAll
Sheet5.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Create named ranges for your source data and for the rows after which you want it to be copied. In this example I've used "source", "range1" and "range2". Then the following code copies the source data into the appropriate place:
Sub copyData()
Dim source As Range, range1 As Range, range2 As Range
Dim r As Range
Set source = Range("source")
Set range1 = Range("range1")
Set range2 = Range("range2")
For Each r In source.Rows
If r.Cells(1, 4).Value = 1 Then
copyRow r, range1
ElseIf r.Cells(1, 4).Value = 2 Then
copyRow r, range2
Else
' handle error here
End If
Next r
End Sub
Sub copyRow(data As Range, targetRange As Range)
Set targetRange = targetRange.Resize(targetRange.Rows.Count + 1, targetRange.Columns.Count)
For i = 1 To 3
targetRange.Cells(targetRange.Rows.Count, i).Value = data.Cells(1, i).Value
Next i
End Sub
There's probably a much more elegant way of doing this involving array formulae, but this should do the trick.
For validating that each cell contains only "1" or "2", you can include additional code where I've put a comment, but you'd be better off handling this as a data validation.
Following is part of my program which does the follwoing function
It will look into column K and column L and create tabs according to the combinations. For example if column K has a cell value "Apple" and column L has one cell value "Orange" it will create a tab 1) Apple - Orange
The new tab will have all the rows with this combination
So once complete the running of macro , the whole data will get divided to different tabs according to the K - L combination
My problem is it is giving a run time error when entire column K or entire column L has only one value. For example if entire K column has 10 rows and all column k cells has value Apple it will give error. same goes for column L.
Dim m As Integer
Dim area As Range
Count = Range("K:K").SpecialCells(xlLastCell).Row
ActiveSheet.Range("K2:K" & Count).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Z2"), Unique:=True
Columns(26).RemoveDuplicates Columns:=Array(1)
Count1 = Range("L:L").SpecialCells(xlLastCell).Row
ActiveSheet.Range("L2:L" & Count1).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Y2"), Unique:=True
Columns(25).RemoveDuplicates Columns:=Array(1)
Dim arrayv As String
Dim Text1 As String
Dim arrayv1 As String
last = Range("Z2").End(xlDown).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y2").End(xlDown).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
Columns(26).EntireColumn.Delete
Columns(25).EntireColumn.Delete
Dim i As Long, j As Long
Dim flag As Variant
flag = 1
A = 1
s = 2
For c = 1 To UBound(arrayv1)
For t = 1 To UBound(arrayv)
Sheets.Add().Name = "Sheet" & s
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
With Worksheets("Sheet1")
j = 2
.Rows(1).Copy Destination:=Worksheets("Sheet" & s).Range("A" & 1)
flag = 1
For i = 2 To Count
If .Cells(i, 11).Value = arrayv(t) Then
If .Cells(i, 12).Value = arrayv1(c) Then
Text = .Cells(i, 15).Value
flag = 0
.Rows(i).Copy Destination:=Worksheets("Sheet" & s).Range("A" & j)
j = j + 1
End If
End If
Next i
If flag = 1 Then
Sheets("Sheet" & s).Delete
Else
Text1 = Left(Text, 4)
Error line when column K has only one value
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
Error line when column L has only one value
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
If there is only one value Y2 or Z2 downwards then using the Range,End property with an xlDirection of xlDown is going to reference row 1,048,576. The WorksheetFunction.Transpose method has a limit of 65,536. Anything exceeding this limit will result in,
Run-time error '13':Type mismatch.
Change the direction of the last-row-seek to look up from the bottom with xlUp.
last = Range("Z" & rows.count).End(xlUp).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y" & rows.count).End(xlUp).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)