I want to merge the values in column B if Duplicates exist in Column A
A B
123 A
123 B
123 C
456 D
456 E
789 F
My output should look like this
A B
123 A B C
456 D E
789 F
I have a large amount of data and it is hard to do it manually ,So u guys have any idea to do it in macros in Excel?
Any help will be appreciated..Thanks in Advance
I'd cheat, and use formulas as follows;
1) Sort by column A
2) In col C, add a formula to test if the current one is last (assuming there's a header, put this in C2
=if(A2<>A3,TRUE,FALSE)
Now, this should only be true for the last cell in a series of same ID's
3) in Col D, add a formula for concatenating if the ID's are the same,
=if(A2=A1,D1&" "&B2,B2)
4) Filter on column C to show only the last cell in each series.
Cheers.
In case you want the resultant data in the same cells the original data existed ie not in Cell 10, then you have to store the source data in a two dimensional array. Then from the array we have use the above code to insert the data in the same place the original data existed. Here goes the listing to accomplish the task:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim names(2 To 7, 2)
For i = 2 To 7
names(i, 1) = Cells(i, 1)
names(i, 2) = Cells(i, 2)
Next
On Error Resume Next:
Sheet1.Cells.Clear
cnt = 2
For i = 2 To 7
strg = strg + names(i, 2)
If names(i + 1, 1) <> names(i, 1) Then
Cells(cnt, 1) = names(i, 1)
Cells(cnt, 2) = strg
cnt = cnt + 1
strg = ""
End If
Next
End Sub
Please note that I have declared names array with two dimesnions to store the data. Then the array is searched to get the result.
You can use the following macro:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
cnt = 10
For i = 2 To 7
strg = strg + Cells(i, 2)
If Cells(i + 1, 1) <> Cells(i, 1) Then
Cells(cnt, 1) = Cells(i, 1)
Cells(cnt, 2) = strg
cnt = cnt + 1
strg = ""
End If
Next
End Sub
The requested data will be printed from Cells 10
Related
I have existing script that does a major chunk of what I need. The script (from here: https://www.extendoffice.com/documents/excel/4054-excel-duplicate-rows-based-on-cell-value.html) basically inserts and then copies rows of data X number of times, where X is one of the fields in the table. It works well and the referenced page shows examples of the start and end points.
But when I run the script in Excel I go from ~2,000 lines in my table to ~40,000 lines. I need to modify all the duplicated rows (incremental dates) and so I am now attemting to also include new data into the table while the script runs that will allow me to change data in the duplicated rows... for example I can use the duplicate number 1, 2, 3, 4 and some simple formulas to change dates relative to a start point.
I expect that I will need some additional code inserted into the routine that will add data into a nominated column and do the auto incrementing from 1.
Having zero actual VBA skillz, ive no idea how to tackle the second part of my problem with the code I already have. Any help would be totally awesome !!
Sub CopyData()
'Updateby Extendoffice 20160922
Dim xRow As Long
Dim VInSertNum As Variant
xRow = 1
Application.ScreenUpdating = False
Do While (Cells(xRow, "A") <> "")
VInSertNum = Cells(xRow, "D")
If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
Range(Cells(xRow, "A"), Cells(xRow, "D")).Copy
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "D")).Select
Selection.Insert Shift:=xlDown
xRow = xRow + VInSertNum - 1
End If
xRow = xRow + 1
Loop
Application.ScreenUpdating = False
End Sub
Try this code below, I used the same sample data on the link you provided. However on this code I created 2 worksheets, one for the raw data to be processed and one for the duplicate output including the increment of dates and duplicate number.
Sub duplicateData()
Dim rSH As Worksheet
Set rSH = ThisWorkbook.Sheets("RAW") 'Your raw data
Dim oSH As Worksheet
Set oSH = ThisWorkbook.Sheets("OUTPUT") 'Output data on another sheet
x = 2
For a = 2 To rSH.Range("A" & Rows.Count).End(xlUp).Row
For b = 1 To rSH.Cells(a, 4).Value '4 is the column of duplicate times
If b = 1 Then
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 5) = 1 'First instance, 5 is the column number of duplicate counter
Else
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 3).Value = CDate(oSH.Cells(x - 1, 3).Value) + 1 '3 is the column number of date to increment
oSH.Cells(x, 5).Value = CInt(oSH.Cells(x - 1, 5).Value) + 1 '5 is the column number of duplicate counter
End If
x = x + 1 'Increment Output row number
Next b
Next a
End Sub
I am trying to add values from different sheets (Sheet 2 to 5) into my main sheet (Sheet 1). In Sheet 1 I want the cells to contain the right formula pointing to the different sheets (if possible).
Typically like this:
='Sheet2'!D5+'Sheet3'!D165
All my sheets have different products, but some sheets contain same products. So I want to search through them all and ADD them in my Main Sheet (Sheet 1).
Sub UpdateMainSheet()
' Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Count As Integer
'Line of code to delete old data in Main Sheet:
Worksheets("Sheet1").Range("A2:H10000").Clear
AktivtArkOverskrift = "List of Articles from Sheet 2 to 5"
'Creates Headline in Main Sheet:
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Sheet1").Cells(eRow, 1) = AktivtArkOverskrift
Worksheets("Sheet1").Cells(eRow, 1).Font.Bold = True
'Script to check and gather data from the other sheets (Sheet 2, 3, 4 and 5):
For K = 2 To 5
'For loop to check each line in sheet "K"
For I = 2 To 1000
'If function to check if the cell I in column F is empty, if so it_jumps to next row and do the same check:
If Worksheets(K).Cells(I, 6) > 0 Then
Count = 0
'For loop to check if I already have a row in the Main Sheet with the article I'm checking:
For L = 2 To 1000
'If function to check if the articles have the same article number:
If Worksheets(K).Cells(I, 1) = Worksheets("Sheet1").Cells(L, 1) Then
'Line of code that are supposed to ADD the values that is currently in the Main Sheet, togheter with the value in Sheet K:
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
End If
Next L
End If
Next I
Next K
End Sub
So what I need to fix in my code is this part (located furthest inside the For Loop):
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
And make it create a formula in the wanted cell, that looks something like this:
='Sheet2'!D5+'Sheet3'!D165
It must be able to add another cell as well, since the Loop are running through several Sheets (Sheet 2 to 5) that may contain the same products.
I.e. I only want one line in my Main Sheet for each product.
I managed to find the solution in the end.
It seemed I had switched the L and I in som of the looping, which resulted in the values not to be added togheter.
The following code (I did not translate to English, but can do this if someone wants/need it) solved my issue, and gave me the values from Sheet 2 to 5 sorted by product in Sheet 1:
Sub OppdaterePlukkelisteSummert()
'Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Teller As Integer
Dim value1 As Integer
Dim value2 As Integer
'Sletter Plukklisten for å oppdatere og sortere på nytt:
Worksheets(1).Range("A2:H10000").Clear
'HENTING AV DATA FRA ARKET "K":
AktivtArk = "Artikler Summert fra Alle Ark"
AktivtArkOverskrift = "Artikler Summert fra Alle Ark"
'Setter inn Overskrift som Forteller kva ark utstyret kommer fra:
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets(1).Cells(eRow, 1) = AktivtArkOverskrift
Worksheets(1).Cells(eRow, 1).Font.Bold = True
'Sjekker hvilke/hvilket rader/utstyr som skal plukkes, og legger det inn i "Ark1":
For K = 2 To 5
For I = 2 To 1000
If Worksheets(K).Cells(I, 6) > 0 Then
Teller = 0
For L = 2 To 1000
If Worksheets(K).Cells(I, 1) = Worksheets(1).Cells(L, 1) Then
value1 = Worksheets(1).Cells(L, 4)
value2 = Worksheets(K).Cells(I, 4)
Worksheets(1).Cells(L, 4) = value1 + value2
Worksheets(1).Cells(L, 6) = value1 + value2
Else
Teller = Teller + 1
End If
Next L
If Teller > 998 Then
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For J = 1 To 11
Worksheets(1).Cells(eRow, J) = Worksheets(K).Cells(I, J)
Next J
Worksheets(1).Cells(eRow, 6).Font.Color = RGB(0, 150, 0)
Worksheets(1).Cells(eRow, 7).Font.Color = RGB(0, 150, 0)
End If
End If
Next I
Next K
Worksheets(1).Range("A2").Select
End Sub
I hope this can be useful for someone else :-)
All help and suggestion in the comments are appreciated!
I was going to illustrate with this simple example:
I = 1 'for example
For K = 2 To 5
Worksheets("Sheet1").Cells(I, 4).Value = Worksheets("Sheet1").Cells(I, 4).Value + _
WorksheetFunction.SumIf(Worksheets(K).Range("A:A"), "Bananas", Worksheets(K).Range("D:D"))
Next K
I am new to VBA, just trying my hands as my requirement is not getting fulfilled by formulas.
Depending on the entry in the cell E2..E3..in column E, new rows to be inserted in another sheet.Also copy the value of A, B & C from sheet 1 to A, C, D of sheet 2 respectively. Column B of Sheet 2 will/should automatically generate the line item no.
for example: if E2 = 2 in Sheet1, then 2 new rows to be added with copied data of A2, B2 and C2 of Sheet 1 into Sheet2.
Please check the attached images:
Sheet1
Sheet2
After going through the forum help, I have tried some coding but this for only one cell value, but I need the code to work for each cell value. Which I am not able to do. Also the line item number (Col B) is coming like 3..2..1 not 1..2..3.
Please check the code:
Code
Regards,
Krish
'Hope this Works for you
Sub transfer_data()
Dim arr() As Variant
Dim cnt, n As Long
arr = Application.Transpose(Application.Transpose(Sheets("Sheet1").Range("A2:E22")))
n = 1
i = 0
For i = LBound(arr) To UBound(arr)
Sheets("Sheet2").Range("A" & n).Value = arr(i, 1)
Sheets("Sheet2").Range("B" & n).Value = arr(i, 5)
Sheets("Sheet2").Range("c" & n).Value = arr(i, 3)
Sheets("Sheet2").Range("D" & n).Value = arr(i, 2)
cnt = arr(i, 5)
n = n + cnt
Next i
End Sub
I have a shared excel sheet with records being entered all the time. I want to find the last consecutive entry of a specific Name(its 'A' in this example) and record the value at the begining and ending of last occurance.
The output of the attached excel should be
A,2,34 ---when i open when there were 5 entries
A,5,null ---when i opened when there were 9 entries
A,9,6 ---when i opened when there were 11 entries
A,9,3 ---when i opened when there were 12 entries
please help me with the formula that i can use in a different tab of same excel.
Thanks
this should work.
in column C use this formula. Works from row2 and down. row1 should be irrelevant (no consecutive entries at this point).
=IF(B1=B2,B2&","&A1&","&A2,"")
You can also have a formula display whatever is the last entry for that value. This is for value "A".
=LOOKUP(2,1/(B:B=E1),C:C)
A UDF should be able to handle the relative loop.
Option Explicit
Function LastConColVals(rng As Range, crit As String, _
Optional delim As String = ",")
Dim tmp As Variant, r As Long, rr As Long
'allow full column references
Set rng = Intersect(rng, rng.Parent.UsedRange)
With rng
tmp = Array(crit, vbNullString, vbNullString)
For r = .Rows.Count To 1 Step -1
If .Cells(r, 2).Value = crit Then
tmp(2) = .Cells(r, 1).Value
For rr = r To 1 Step -1
If .Cells(rr, 2).Value = crit Then
tmp(1) = .Cells(rr, 1).Value
Else
Exit For
End If
Next rr
'option 1 - null last value for singles
If rr = (r - 1) Then tmp(2) = "null"
'option 2 - truncate off last value for singles
'If rr = (r - 1) Then ReDim Preserve tmp(UBound(tmp) - 1)
Exit For
End If
Next r
End With
LastConColVals = Join(tmp, delim)
End Function
I have a excel sheet with 2 columns
Contact Status Max Probability
80-Opp Closed Won
0-NC Closed Won
40-Pending 30-Connect
10-Working 20- Engagement
80-Opportunity 30-Connect
40-Pending 10- Engagement
I need to check if the no in contact status ie the numeric value before '-' is less than numeric value in max probabilty before '-', then i need the whole value of max probability update the contact status field
For eg.
10-Working 20- Engagement
10-Working should be replaced by 20- Engagement
OR
We can have 20- Engagement in a new column if the above mentioned conditioned is satisfied, if replacing the contact Status column is difficult
How can achieve this?
This little macro will do the trick. Just change Row to the starting row and ColA/B to the two columns you want to use.
Note that GetNum returns -1 if there is no number at the start which, in this implementation, means no copying. It was unclear what you wanted to do tith Closed Won so I chose the safest option. If you do want it copied, just return a huge number instead of -1.
Option Explicit
Function GetNum(s As String) As Integer
If Mid(s, 1, 1) < "0" Or Mid(s, 1, 1) > "9" Then
GetNum = -1
Else
GetNum = Val(s)
End If
End Function
Sub Macro1()
Dim Row As String
Dim ColA As String
Dim ColB As String
ColA = "A"
ColB = "B"
Row = "2"
While Range(ColA & Row).Value <> ""
If GetNum(Range(ColA & Row).Value) < GetNum(Range(ColB & Row).Value) Then
Range(ColA & Row).Value = Range(ColB & Row).Value
End If
Row = CStr(Val(Row) + 1)
Wend
End Sub
This was tested on:
to generate:
This macro will do:
Sub a()
ColumnContSt=1
ColumnMaxProb=2
i = 1
While (Cells(i, 2) <> "")
colB = Cells(i, ColumnMaxProb)
colA = Cells(i, ColumnContSt)
posB = InStr(1, colB, "-")
posA = InStr(1, colA, "-")
If (posB <> 0 And posA <> 0) Then
intColB = CInt(Mid(colB, 1, posB - 1))
intColA = CInt(Mid(colA, 1, posA - 1))
If (intColA < intColB) Then
Cells(i, 1) = Cells(i, 2)
End If
End If
i = i + 1
Wend
End Sub
Just change ColumnContSt = 1 and ColumnMaxProb = 2 for your actual column NUMBERS ie. A=1, B=2, etc.
HTH!
If you are flexible about the actual data, the easiest way to do this is to make two columns (can be hidden in some far away sheet):
0 NC
10 Engagement
30 Connect
...
And then use VLOOKUP(CELL_WITH_PROBABILITY, REGION_WITH_TABLE, 2, true). So if you put my small 3 element table in the upper corner of a sheet and probability in C1, it'd look like VLOOKUP(A1:B3, C1, 2, true)