根据单元格值将特定数据（不是整行！）复制到另一张表

Question

I am trying to copy cell data from one sheet to another based on a match.

I have a workbook with 3 sheets. "Place", "Coke" and "HMS".

On Active sheet "Place", If column C14 has the word "Coke" - I want D14-H14 copied to the sheet "Coke".

Similarly if C15 contains "HMS" - I want only "D15-H15" Copied to the sheet "HMS"

I have a macro that copies the entire row while I want specific cells copied - which is from the specific C:H.

Sub As_Of_Analysis_Sorting()
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Place").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Coke").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("HMS").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If Range("C" & r).Value = "Coke" Then
        Rows(r).Copy Destination:=Sheets("Coke").Range("A" & lr2 + 1)
        lr2 = Sheets("Coke").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If Range("C" & r).Value = "HMS" Then
        Rows(r).Copy Destination:=Sheets("HMS").Range("A" & lr3 + 1)
        lr3 = Sheets("HMS").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    Range("A140").Select
Next r
End Sub

Hos do I achieve this?

Answer 1

Firstly a "good practice" suggestion: always tell which sheet the range is in:

Range("C" & r).Value 
'becomes
Range("Place!C" & r).Value 
'or
sheets("Place").Range("C" & r).Value 

Now the answer: the code just does what you told it to do:

Rows(r).Copy Destination:=Sheets("Coke").Range("A" & lr2 + 1)

==> you copy the whole row and place it in A. That's replacing the whole row If you do NOT need format, you should use this:

range("Coke!A" & lr2 +1 & ":F" & lr2 +1 ) = range("Place!C" & r & ":H" & r).value2

if you need format (slower code) :

range("Place!C" & r & ":H" & r).copy  Destination:=Sheets("Coke").Range("A" & lr2 + 1)