![]() |
#2
|
||||
|
||||
![]()
You could add a macro like the following to your 'main' sheet's code module, but you'll need to fix your spelling before the code will work properly.
Code:
Private Sub Worksheet_Change(ByVal Target As Range) Dim lRowTgt As Long, lRowDst As Long, i As Long, j As Long Dim StrDst As String, bFilled As Boolean, bDiff As Boolean, bCol As Boolean With Target.Worksheet ' Find the last row on the input sheet lRowTgt = .Range("A" & .Rows.Count).End(xlUp).Row ' Check whether we're on the last row If Not Intersect(Target, .Range("A" & lRowTgt & ":D" & lRowTgt)) Is Nothing Then ' Check whether all cells in columns A:D on the last row are filled in bFilled = True For i = 1 To 4 If .Cells(lRowTgt, i).Value = "" Then bFilled = False End If Next If bFilled = True Then ' All cells in columns A:D on the last row are filled in With Target.Worksheet ' Find the output sheet StrDst = "Customer " & UCase(Trim(.Cells(lRowTgt, 1).Value)) ' Find the last row on the output sheet With Sheets(StrDst) lRowDst = .Range("A" & .Rows.Count).End(xlUp).Row End With ' See if we can find a row on the output sheet that has the same values as the input sheet For i = 2 To lRowDst bDiff = True If .Cells(lRowTgt, 2).Value = Sheets(StrDst).Cells(i, 1).Value And _ .Cells(lRowTgt, 3).Value = Sheets(StrDst).Cells(i, 2).Value And _ .Cells(lRowTgt, 4).Value = Sheets(StrDst).Cells(i, 3).Value Then bDiff = False: Exit For End If Next If bDiff = True Then ' No matches, so copy from the input sheet to the output sheet lRowDst = lRowDst + 1 .Range("B" & lRowTgt & ":D" & lRowTgt).Copy With Sheets(StrDst) .Paste Destination:=.Range("A" & lRowDst) End With End If End With End If End If ' Find the last row on the input sheet lRowTgt = .Range("F" & .Rows.Count).End(xlUp).Row ' Check whether we're on the last row If Not Intersect(Target, .Range("F" & lRowTgt & ":I" & lRowTgt)) Is Nothing Then ' Check whether all cells in columns F:I on the last row are filled in bFilled = True For i = 6 To 9 If .Cells(lRowTgt, i).Value = "" Then bFilled = False End If Next If bFilled = True Then ' All cells in columns F:I on the last row are filled in With Target.Worksheet ' Find the output sheet StrDst = "Customer " & UCase(Trim(.Cells(lRowTgt, 6).Value)) ' Find the last row on the output sheet With Sheets(StrDst) lRowDst = .Range("F" & .Rows.Count).End(xlUp).Row End With ' See if we can find a row on the output sheet that has the same values as the input sheet For i = 2 To lRowDst bDiff = True If .Cells(lRowTgt, 7).Value = Sheets(StrDst).Cells(i, 5).Value And _ .Cells(lRowTgt, 8).Value = Sheets(StrDst).Cells(i, 6).Value And _ .Cells(lRowTgt, 9).Value = Sheets(StrDst).Cells(i, 7).Value Then bDiff = False: Exit For End If Next If bDiff = True Then ' No matches, so copy from the input sheet to the output sheet lRowDst = lRowDst + 1 .Range("G" & lRowTgt & ":I" & lRowTgt).Copy With Sheets(StrDst) .Paste Destination:=.Range("E" & lRowDst) End With End If End With End If End If End With Application.CutCopyMode = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to Copy data from Outlook mail and Paste it in a Excel sheet? | padhu1989 | Outlook | 0 | 09-11-2012 04:07 AM |
sheet 2 data highlight in sheet 1 | gsrikanth | Excel | 1 | 04-21-2012 06:25 PM |
![]() |
fuchsd | Word | 6 | 10-25-2011 05:52 AM |
If two geographical data match in two sheets, copy unique id/code found in one sheet | alliage | Excel | 1 | 09-01-2011 05:23 AM |
copy cell from sheet 2 to sheet 3 macro | slipperyjim | Excel Programming | 1 | 02-18-2010 01:31 AM |