Copying only specific cells to different sheets if certain conditions are true - excel

Question

I am working with 4 rows (test bed for my code) and each product is allocated 2 rows: Data range is A1:E5
Fizzy Drink Australia Perth no sugar High
Fizzy Drink 3 5 7 5
Still water Australia Perth flavoured High
Still water 4 7 5 4
The above is on sheet 1 and there's a sheet for each produce i.e. total 3 sheets. I'm using a For loop in column 'A' to find the product and then copy the text in each of the 4 columns to the right onto the respective product sheets in columns H1:K1. This text acts as headers for each product sheet, so the headers are not the same for each product. Each product's text must be copied to the correct product sheet.
I'm having problems copying the text attached in the first row against each product in column 'A', as the 2nd row has values. The format is same for all the products - 2 rows - first row for text and second for formulas.
The challenge (which I have failed miserably) is to make the code copy text in columns B:E for each particular product.
The text can change on often basis so if the code can identify the product in column 'A' and copy/paste the text that would be fantastic.
Option Explicit
Sub copy_Text_Formulas_to_sheets
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim Lastrow As Long
Dim Lastrow1 As Long
Dim Lastrow2 As Long
Dim i As Integer
Dim j As Integer
Set ws1 = ThisWorkbook.Worksheets("Key") 'this is the sheet I'm pulling data from
Set ws2 = ThisWorkbook.Worksheets("Fizzy Drink") 'this is the worksheet I'm pulling data into for Prd1
Set ws3 = ThisWorkbook.Worksheets("still water") 'this is the worksheet I'm pulling data into for Prd2
Lastrow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Lastrow1 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
Lastrow2 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
For j = 1 To Lastrow
If ws1.Cells(i, "A").Value = "Fizzy Drink" And ws1.Cells(i, "B").Value = "Australia" And _
ws1.Cells(i, "C").Value = "Perth" And ws1.Cells(i, "D").Value = "no sugar" And ws1.Cells(i, "E").Value = "High" Then
ws1.Range("B" & i, "E" & i).Copy 'copy row with text from B to E including all formatting
ws2.Select
ws2.Range("H1:K1").PasteSpecial xlPasteValues
'If the above conditions are not met msg user
End If
If ws1.Cells(j, "A").Value = "Fizzy Drink" And ws1.Range(i,"B:E").HasFormlua Then
ws2.Range("B2:E2") = ws1.Range(j, "H:K") 'copy the formulas in row B:E with relative references
'If the above conditions are not met msg user
End If
If ws1.Cells(i, "A").Value = "still water" And ws1.Cells(i, "B").Value = "Australia" And _
ws1.Cells(i, "C").Value = "Perth" And ws1.Cells(i, "D").Value = "flavoured" And ws1.Cells(i, "E").Value = "High" Then
ws1.Range("B" & i, "E" & i).Copy 'copy row with text from B to E including all formatting
ws3.Select
ws3.Range("H1:K1").PasteSpecial xlPasteValues 'copy including all formatting
'If the above conditions are not met msg user
End If
If ws1.Cells(j, "A").Value = "still water" And ws1.Range(i, "B:E").HasFormlua Then
ws2.Range("B2:E2") = ws1.Range(j, "H:K") 'copy the formulas in row B:E with relative references
'If the above conditions are not met msg user
End If
Next j
Next i
On Error Resume Next
ws2.Range("B2:E2").AutoFill Destination:=Range("B2:E" & Lastrow1) 'copy formula in row to down to lastrow
ws3.Range("B2:E2").AutoFill Destination:=Range("B2:E" & Lastrow2) 'copy formula in row to down to lastrow

Answer 1

This should help. I didn't do anything with the header row because I don't know why you would have to change it one, let alone once for each record.
Sub copy_Text_Formulas_to_sheets1()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim Lastrow As Long, i As Long
Dim msg as String
Set ws1 = ThisWorkbook.Worksheets("Key") 'this is the sheet I'm pulling data from
Set ws2 = ThisWorkbook.Worksheets("Fizzy Drink") 'this is the worksheet I'm pulling data into for Prd1
Set ws3 = ThisWorkbook.Worksheets("still water") 'this is the worksheet I'm pulling data into for Prd2
With ws1
Lastrow = .Cells(ws1.rowS.Count, "A").End(xlUp).Row
MsgBox "Last Row:" & Lastrow
For i = 1 To Lastrow
msg = msg & .Cells(i, "A") & vbcrlf
If IsNumeric(.Cells(i, 2)) Then
If .Cells(i, "A").value = "Fizzy Drink" Then
.Range(.Cells(i, "B"), .Cells(i, "E")).Copy getNextRow(ws2, "H")
ElseIf .Cells(i, "A").value = "Still water" Then
.Range(.Cells(i, "B"), .Cells(i, "E")).Copy getNextRow(ws3, "H")
End If
End If
Next
MsgBox "Range B2 is Numeric:" & .Cells(2, 2) & vbCrLF & "Range B3 is Numeric:" & .Cells(3, 2)
MsgBox "Range B2 has formula:" & .Cells(2, 2).HasFormula & vbCrLF & "Range B3 has formula:" & .Cells(3, 2).HasFormula
MsgBox msg
End With
End Sub
Function getNextRow(xlWorksheet As Worksheet, colmnLetter As String) As Range
Set getNextRow = xlWorksheet.Cells(rowS.Count, colmnLetter).End(xlUp).Offset(1, 0)
End Function
I added a couple of message to see what's up. Let me know what you get back. Can you provide a download link with sample data?