I am trying to compare two sheets within one workbook. I need to match values in column A of the first sheet with column A of sheet 2 and, if a matching value is found, copy and paste a value from column E of sheet 2 into column E of sheet 1. For example:
Sheet 1: A B C D E Sheet 2: A B C D E
k 9 b 3 k d 3 d 6
j 2 d 4 m h 4 g 3
s 3 u 9 j e 8 a 9
i 4 s 6 s i 9 t 7
o 7 n 8 l b 10 s 9
i c 4 p 8
o l 0 n 9
Would become
Sheet 1: A B C D E
k 9 b 3 6
j 2 d 4 9
s 3 u 9 7
i 4 s 6 8
o 7 n 8 9
The code I am currently working with is:
Sub mergeCategoryValues()
Dim lngRow As Long
With ActiveSheet
lngRow = .Cells(65536, 1).End(xlUp).Row
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes
Do
If .Cells(lngRow, 1) = Sheets("Sheet2").Cells(lngRow, 1) Then
.Cells(lngRow, 5) = Sheets("Sheet2").Cells(lngRow, 5)
End If
lngRow = lngRow - 1
Loop Until lngRow < 2
End With
End Sub
I need to pull duplicates regardless of case. Is this possible?
Any help is appreciated.
Thank you in advance.
I've worked out a VBA code:
Sub sof20355637MergeCategoryValues()
Dim i As Long, i2 As Long, lngRow As Long, lngRow2 As Long
Dim strKey As String
Dim wks1, wks2 As Worksheet
Dim objRange2
Set wks1 = Sheets("Sheet1")
Set wks2 = Sheets("Sheet2")
' get mximum rows of each sheet:
lngRow = wks1.Cells(wks1.Rows.Count, 1).End(xlUp).Row
lngRow2 = wks2.Cells(wks1.Rows.Count, 1).End(xlUp).Row
' we loop on the first column of sheet1:
For i = 1 To lngRow
strKey = wks1.Range("A" & i)
Set objRange2 = wks2.Range("A:A").Find(strKey, Range("A1"), SearchDirection:=xlPrevious)
If (Not objRange2 Is Nothing) Then
i2 = objRange2.Row
wks1.Range("E" & i) = wks2.Range("E" & i2)
End If
Next
Set objRange2 = Nothing
Set wks1 = Nothing
Set wks2 = Nothing
End Sub
With some images:
Sheet1: Sheet2:
Merged Sheet1:
Assuming k on Sheet 1 is in A1, then in E1 of Sheet 1:
=VLOOKUP(A1,'Sheet 2'!A:E,5,0)
and copied down to suit may serve, though not VBA.
Related
I have data in column A with 50000 rows of data. I need to transpose every 6 rows of data to 6 columns. For example data from A1:A6 must be transposed to B1:G1. Again data from A7:A14 must be transposed to B2:G2. I appreciate if anyone can provide VBA code for this.
Data I have in column A is as shown below:
Col A
1
2
3
4
5
6
7
8
9
10
11
12
The transpose data must be as shown below in col B to col G:
Columns B C D E F G
1 2 3 4 5 6
7 8 9 10 11 12
Try this:
Sub TransposeRows()
Dim rng As Range
Dim i As Long
Set rng = Range("A1")
While rng.Value <> ""
i = i + 1
rng.Resize(6).Copy
Range("B" & i).PasteSpecial Transpose:=True
Set rng = rng.Offset(6)
Wend
Application.CutCopyMode = False
End Sub
Got this from here.
additional variant from my side:
Sub TransposeRows2()
Dim i&, z&, x&
i = Cells(Rows.Count, "A").End(xlUp).Row
z = 1: x = 1
While z <= i
Range("B" & x).Resize(, 6) = _
WorksheetFunction.Transpose(Range("A" & z).Resize(6))
z = z + 6: x = x + 1
Wend
End Sub
tested:
You do not need a macro for this. In B1 enter:
=OFFSET($A$1,COLUMNS($A:A)-1+(ROWS($1:1)-1)*6,0)
Then copy both across and down:
In Portuguese Excel, "Gary's Student"'s formula, for 4 columns instead of 6, becomes:
=DESLOCAMENTO($A$1;COLS($A:A)-1+(LINS($1:1)-1)*4;0)
I have an excel table that has some duplicates and we currently have a count of these however I want to populate a unique number for each duplicate. e.g.
Number Count Sequence
1 2 1
1 2 1
2 3 2
2 3 2
2 3 2
3 4 3
3 4 3
3 4 3
3 4 3
4 2 4
4 2 4
5 5 5
5 5 5
5 5 5
5 5 5
5 5 5
I was playing with the following IF statement but I want it to check through the whole range and check if it has any in a wrong order but still the same.
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
is this possible?
It will add the unique ref into the a Column which is 3 columns up from what every you set col equal to.
It also requires that col + 3 to be blank, this will make the checking easier.
Sub SomeSub()
Dim Array1 As Variant
Dim Array2 As Variant
With ActiveSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
'Setting up the array for assigning each row value to the array
ReDim Array1((LastRow + 1))
ReDim Array2((LastRow + 1))
'Here youwill set what column is the "Number" Column
col = 1
'Assigning the row data into the arrays
'Starting at 2 to skip the title row
For r = 2 To LastRow
'Values in Column 1 go to Array1
Array1(r) = Cells(r, col)
'Values in Column 2 go to Array2
Array2(r) = Cells(r, col + 1)
Next r
'Setting unquie ref to 1
Seq = 1
'Running through each row of data
For i = 2 To LastRow
'col + 3 refers to a column on beyond the Sequence colum
'If the column is blank then that row has not been checked yet
If Cells(i, col + 3) = "" Then
'Assign the Uniqui ref to the row
Cells(i, col + 3).Value = Seq
'Running through the rest of the rows to check if they are like the current row
For n = i + 1 To (LastRow)
'If cell is blank then the row has been checked
If Cells(n, col + 3) = "" Then
'Array(i) is the current row
'Array(n) are the leading rows after row i
'If the current row is the same as any leading row then the uniquie ref = seq
If Array1(i) = Array1(n) And Array2(i) = Array2(n) Then Cells(n, col + 3).Value = Seq
'Else a value has been added
Else
'Do nothing
End If
Next n
'Increment the seq
Seq = Seq + 1
'Ending the If Cells(i, col + 3) = "" Then
End If
Next i
End Sub
You can first loop through the column and get the unique items using collections.
This part of the code:
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
Will only get the unique items, as a collection of items cannot have duplicates.
Use this to Number the duplicates.Change the sheet name as required.
Sub NumberDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
.Columns("B:B").ClearContents
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 1
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Offset(, 1) = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
Use this to Color the Duplicates, this will work on a small scale, depends on how many unique items there are, it's cool example though. Edited code from my answer here.
Sub ColorDupes()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Long, clr As Long, x, r As Range
Set sh = Sheets("Sheet2")
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(LstRw, 1))
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For c = 1 To LstRw
Set r = .Cells(c, 1)
x = Application.WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(c, 1)), r)
If r = vNum Then
If x > 1 Then
r.Interior.ColorIndex = clr
End If
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
In C1 just 1 and in C2:
=MIN(IF(($A$2:A2=A3)*($B$2:B2=B3),$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
and simply autofill down from C3
hmm... i think i got it wrong :/
if only looking at Column A then this should be enough:
=MIN(IF($A$2:A2=A3,$D$2:D2,MAX($D$2:D2)+1))
This is an array formula and must be confirmed with Ctrl+Shift+Enter.
looking at your formula it can be shortened:
=IF(IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)>=0,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0)+D1,IF(IF(A2=A1,TRUE,FALSE)=FALSE,1,0))
'IF(A2=A1,TRUE,FALSE)=FALSE ==>> A1<>A2
=IF(IF(A1<>A2,1,0)>=0,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(A1<>A2,1,0)>=0 ==>> TRUE
=IF(TRUE,IF(A1<>A2,1,0)+D1,IF(A1<>A2,1,0))
'IF(TRUE => allways true
=IF(A1<>A2,1,0)+D1
'last skip
=D1+(A1<>A2)
In Excel I have a the following set up in Sheet 1
A B C D E
1 a 12 123
2 b 234 2342
3 c 12 23 54 342
4 d 234 33 54
5 e 234 34 66
6 f 345
and the table below in Sheet 2
A B
1 b 2
2 d 3
3 e 1
Sheet 2 determines if some extra rows should be added to Sheet 1 or not, and if not, the row should be deleted.
Giving the result below in Sheet 1
A B C D
1 b 234 2342
2
3
4 d 234 33 54
5
6
7
8 e 234 34 66
9
Note that b,d & e were the only rows remaining from the original data and also the number of rows added below that row relate to the number in column B in sheet 2 for each remaining row.
I would like to use VBA to carry this out. I have read that deleting rows based on criteria means you need to go through a loop from the bottom row to the top row, but I am struggling to make it work for my example.
Here is the code I have used so far but it doesn't seem to work:
Sub maketab()
Range("A1").Select
Dim r As Long
lr = Range("A1").Row
hr = Range("A1").Offset(8 - 1).Row
For r = hr To lr Step -1
Dim given_rng As Range
Set given_rng = Sheet2.Range("A1")
Dim p As Long
lr_small = given_rng.Row
hr_small = given_rng.End(xlDown).Row
For p = hr_small To lr_small Step -1
If Range("A" & r).Value = Range("A" & p).Value Then
'Add a row below
Range("A" & r).Offset(1).Select
Selection.Resize(Sheet2.Range("A" & p).Offset(0, 1).Value).EntireRow.Insert
Range("A" & r).Select
Else
'Delete a row
Rows(r & ":" & r).Select
Selection.Delete Shift:=xlUp
End If
Next p
Next r
End Sub
As always any help would be greatly appreciated
Try this:
Sub test()
Dim xlws1 As Worksheet
Dim xlws2 As Worksheet
Dim xlws3 As Worksheet
Dim i As Integer
Dim j As Integer
Dim k As Integer
'setting sheet variables
Set xlws1 = Worksheets("Sheet1")
Set xlws2 = Worksheets("Sheet2")
Set xlws3 = Worksheets("Sheet3")
k = 1 'setting initial value of k
i = 1 'setting initial value of i
Do While IsEmpty(xlws1.Range("A" & i)) = False
j = 1 'resetting j
Do While IsEmpty(xlws2.Range("A" & j)) = False 'setting loop up
If xlws1.Range("A" & i).Value = xlws2.Range("A" & j).Value Then 'if value matches current sheet 1 value
xlws1.Rows(i).Copy ' copy row
xlws3.Range("A" & k).PasteSpecial xlPasteAll 'paste row
k = k + 1 'increment k
Exit Do ' move on
End If
j = j + 1 'increment j
Loop
i = i + 1 'increment i
Loop
End Sub
Using office 2010. everything is in same sheet.
Data in Column A B C & D can change (increase or decrease daily)
I have 4 column
OUTPUT --> IN column F should be
---A-----B-----C------D---------------------------------------F
1 5 8 AP 1
2 6 9 BP 2
3 7 1 CD 3
4 5 QW 4
5
6
7
8
9
1
5
AP
BP
CD
QW
length of columns A B C & D can increase of decrease.
How about this?
Sub move()
Dim ws As Worksheet
Dim outputColumn As Long
Dim currentColumn As Long
Dim currentOutputRow As Long
Set ws = ActiveSheet
outputColumn = 6 ' column f
For currentColumn = 1 To 4
currentOutputRow = ws.Cells(ws.Rows.Count, outputColumn).End(xlUp).Row
If (currentOutputRow > 1) Then
currentOutputRow = currentOutputRow + 1
End If
ws.Range(ws.Cells(1, currentColumn), ws.Cells(ws.Rows.Count, currentColumn).End(xlUp)).Copy _
ws.Cells(currentOutputRow, outputColumn)
Next
End Sub
use the below. It accepts the range you need to change and will return a vertical array of values. To fill the values use an array formula.
Function ToVector(rng As Range)
Dim cells()
ReDim cells(rng.cells.Count)
Dim i As Double
For Each cell In rng
cells(i) = cell
i = i + 1
Next cell
ToVector = Application.WorksheetFunction.Transpose(cells)
End Function
With the help of this site get-digital-help.com/
Combine Columns But this is only static.
I converted it to dynamic meaning changing range.
for example I posted A B C D IN F
To make formula more clear will enter formula in Name Manager
BELOW IS DYNAMIC FORMULA FOR EACH COLUMN (goes in name manger)
ALIST = =OFFSET($A$1,0,0,COUNTA($A:$A),1)
BLIST = =OFFSET($B$1,0,0,COUNTA($B:$B),1)
CLIST = =OFFSET($C$1,0,0,COUNTA($C:$C),1)
DLIST = =OFFSET($D$1,0,0,COUNTA($D:$D),1)
FORMULA IN COLUMN F and drag down
=IFERROR(INDEX(ALIST, ROWS(F$1:$F1)),
IFERROR(INDEX(BLIST, ROWS(F$1:$F1)-ROWS(ALIST)),
IFERROR(INDEX(CLIST, ROWS(F$1:$F1)-ROWS(ALIST)-ROWS(BLIST)),
IFERROR(INDEX(DLIST, ROWS(F$1:$F1)-ROWS(ALIST)-ROWS(BLIST)-ROWS(CLIST)),""))))
Screenshot
If I have all data in one very long column like this:
A
B
C
1
2
3
D
E
F
4
5
6
G
H
I
7
8
9
Is it possible to move data like this?
Column1 Column2 Column3 Column4 Column5 Column6
A B C 1 2 3
D E F 4 5 6
G H I 7 8 9
I tried paste special+transpose , but I have more than 10 thousands records , so it will take me too much time in using this method.
I'm new in excel and macro , thank you very much.
Edit:
I even tried to transpose all data into many columns then select the column I want to make them all into one column with this macro:
Sub OneColumn()
' Jason Morin as amended by Doug Glancy
' http://makeashorterlink.com/?M19F26516
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length
'into 1 continuous column in a new sheet
''''''''''''''''''''''''''''''''''''''''''
Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws_from = ActiveWorkbook.ActiveSheet
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column
'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0
'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"
For from_colndx = 1 To from_lastcol
from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
'If you're going to exceed 65536 rows
If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
Else
MsgBox "This time you've gone to far"
Exit Sub
End If
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next
' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it will just join all column into one but not the column selected.
For Remou reference:
Here is the output:
A D G
B E H
C F I
1 4 7
2 5 8
3 6 9
You can look at something in these lines:
Sub TransposeColumn()
Dim rng As Range
Dim ws As Worksheet
Set rng = Worksheets("Input").UsedRange
Set ws = Worksheets("Output")
j = 1
k = 1
For i = 1 To rng.Rows.Count
If rng.Cells(i, 1) = vbNullString Then
j = j + 1
k = 1
Else
''ws.Cells(k, j) = rng.Cells(i, 1)
''EDIT
ws.Cells(j, k) = rng.Cells(i, 1)
k = k + 1
End If
Next
End Sub
This is how I do the same thing... it creates the new table in column C over...based on your example that there is a blank cell between each group of data:
Sub TransposeGroups()
Dim RNG As Range, Grp As Long, NR As Long
Set RNG = Range("A:A").SpecialCells(xlConstants)
NR = 1
For Grp = 1 To RNG.Areas.Count
RNG.Areas(Grp).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Grp
End Sub
This should work for any length of data and "groups" of up to 8500 within the data.
This also uses the AREAS method, but this overcomes the groups limitation by using subgroups, so it should work with any size dataset.
Sub TransposeGroups2()
'Uses the AREAS method and will work on any size data set
'overcomes the limitation of areas by working in subgroups
Dim RNG As Range, rngSTART As Range, rngEND As Range
Dim LR As Long, NR As Long, SubGrp As Long, Itm As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
NR = 1
SubGrp = 1
Set rngEND = Range("A" & SubGrp * 10000).End(xlUp)
Set RNG = Range("A1", rngEND).SpecialCells(xlConstants)
Do
For Itm = 1 To RNG.Areas.Count
RNG.Areas(Itm).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Itm
If rngEND.Row = LR Then Exit Do
Set rngSTART = rngEND.Offset(1)
SubGrp = SubGrp + 1
Set rngEND = Range("A" & (SubGrp * 10000)).End(xlUp)
Set RNG = Range(rngSTART, rngEND).SpecialCells(xlConstants)
Loop
End Sub