Att data from one sheet to another

  • Thread starter Thread starter Jeremy
  • Start date Start date
J

Jeremy

I have a rather large database with two sheets of data. I want to take sheet
two and put the data in column C to sheet one column C where A and B match on
both sheets.

Sheet One
A B C
1 100 4
2 200 1
3 200 2
4 200 5


Sheet Two
A B C
1 100 4 CAR12
2 100 4 WIL13
3 100 4 CAR14
4 200 1 CAR15
5 200 1 CAR16
6 200 2 CAR17
7 200 5 WIL18

What the result should look like
A B C
1 100 4 CAR12; WIL13; CAR14
2 200 1 CAR15; CAR16
3 200 2 CAR17
4 200 5 WIL18
 
Change the "Set Sht" lines to match the names in your worksheet.

Sub CombineSheets()

Set Sht1 = Sheets("Sheet1")
Set Sht2 = Sheets("Sheet2")
With Sht1
Sh1RowCount = 1
Do While .Range("A" & Sh1RowCount) <> ""
Sh2RowCount = 1
Data = ""
With Sht2
Do While .Range("A" & Sh2RowCount) <> ""
If Sht1.Range("A" & Sh1RowCount) = _
.Range("A" & Sh2RowCount) And _
Sht1.Range("B" & Sh1RowCount) = _
.Range("B" & Sh2RowCount) Then

If Data = "" Then
Data = .Range("C" & Sh2RowCount)
Else
Data = Data & "; " & .Range("C" & Sh2RowCount)
End If
End If
Sht1.Range("C" & Sh1RowCount) = Data
Sh2RowCount = Sh2RowCount + 1
Loop
End With
Sht1.Range("C" & Sh1RowCount) = Data
Sh1RowCount = Sh1RowCount + 1
Loop
End With

End Sub
 
Hi Jeremy

The following code will do what you want

Sub Consolidate()

Dim i As Long, lr As Long
Dim wss As Worksheet, wsd As Worksheet
Dim rng1 As Range, rng2 As Range
Application.ScreenUpdating = False
Set wss = ThisWorkbook.Sheets("Sheet1") ' Source
Set wsd = ThisWorkbook.Sheets("Sheet2") 'Destination
lr = wsd.Cells(Rows.Count, "A").End(xlUp).Row
If wss.AutoFilterMode = False Then
If wss.Range("A1") <> "" Then
wss.Rows("1:1").Insert Shift:=xlDown
End If
wss.Range("A1:B1").AutoFilter
End If
For i = 1 To lr
Selection.AutoFilter Field:=1, Criteria1:=wsd.Cells(i, 1).Value
Selection.AutoFilter Field:=2, Criteria1:=wsd.Cells(i, 2).Value
Set rng1 = wss.AutoFilter.Range.Columns(3).Cells
Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1, 1)
Set rng2 = rng1.SpecialCells(xlVisible)
rng2.Copy
wsd.Cells(i, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next i
Application.ScreenUpdating = True
End Sub

Copy the Code above
Alt+F11 to invoke the VB Editor
Insert>Module
Paste code into white pane that appears
Alt+F11 to return to Excel

To use
Select sheet containing the PT's
Alt+F8 to bring up Macros
Highlight the macro name
Run
 
You enter the formula by pressing ctrl + shift & enter as opposed to just
pressing enter
Lookup array formulas in help

--


Regards,


Peo Sjoblom
 
I was not able to get this to work.

Roger Govier said:
Hi Jeremy

The following code will do what you want

Sub Consolidate()

Dim i As Long, lr As Long
Dim wss As Worksheet, wsd As Worksheet
Dim rng1 As Range, rng2 As Range
Application.ScreenUpdating = False
Set wss = ThisWorkbook.Sheets("Sheet1") ' Source
Set wsd = ThisWorkbook.Sheets("Sheet2") 'Destination
lr = wsd.Cells(Rows.Count, "A").End(xlUp).Row
If wss.AutoFilterMode = False Then
If wss.Range("A1") <> "" Then
wss.Rows("1:1").Insert Shift:=xlDown
End If
wss.Range("A1:B1").AutoFilter
End If
For i = 1 To lr
Selection.AutoFilter Field:=1, Criteria1:=wsd.Cells(i, 1).Value
Selection.AutoFilter Field:=2, Criteria1:=wsd.Cells(i, 2).Value
Set rng1 = wss.AutoFilter.Range.Columns(3).Cells
Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1, 1)
Set rng2 = rng1.SpecialCells(xlVisible)
rng2.Copy
wsd.Cells(i, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next i
Application.ScreenUpdating = True
End Sub

Copy the Code above
Alt+F11 to invoke the VB Editor
Insert>Module
Paste code into white pane that appears
Alt+F11 to return to Excel

To use
Select sheet containing the PT's
Alt+F8 to bring up Macros
Highlight the macro name
Run
Click to expand...
 
Hi Jeremy

In what way?
Did it crash?
Did it give the wrong result?
It worked perfectly on the set of data you posted.

If you want to send me the workbook, with the code that you added, I will
take a look.
To mail direct, send to
roger at technology4u dot co dot uk
Change the at and dots to make a valid email address.
 
hi Jeremy
Were your sheets called Sheet1 and Sheet2?
If not, change the names where it says Source and Destination to match your
sheet names
 
Back
Top