Att data from one sheet to another

[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

 

[Joel]

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

 

[Roger Govier]

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

 

[Teethless mama]

Download and install the free add-in Morefunc.xll from:

http://xcell05.free.fr/morefunc/english/index.htm
then use this formula

=SUBSTITUTE(TRIM(MCONCAT(IF((Sheet2!$A$1:$A$7=A1)*(Sheet2!$B$1:$B$7=B1),Sheet2!$C$1:$C$7,"")&" "))," ","; ")

ctrl+shift+enter, not just enter
copy down

 

[Jeremy]

What do you mean by ctrl+shift+enter?

Download and install the free add-in Morefunc.xll from:

http://xcell05.free.fr/morefunc/english/index.htm
then use this formula

=SUBSTITUTE(TRIM(MCONCAT(IF((Sheet2!$A$1:$A$7=A1)*(Sheet2!$B$1:$B$7=B1),Sheet2!$C$1:$C$7,"")&" "))," ","; ")

ctrl+shift+enter, not just enter
copy down

 

[Peo Sjoblom]

You enter the formula by pressing ctrl + shift & enter as opposed to just
pressing enter
Lookup array formulas in help

--


Regards,


Peo Sjoblom

 

[Jeremy]

I was not able to get this to work.

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

 

[Roger Govier]

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.

 

[Roger Govier]

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