コピーのみが特定の細胞、特定の条件が真

Question

である場合、私は4行（私のコードのためのテストベッド）で働いていると、各製品は、2列に割り当てられている：データ範囲が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 

上記はシート1にあり、それぞれのシート、すなわち合計3枚のシートがある。私は列 'A'のForループを使用して製品を見つけ、右側の4つの列のそれぞれのテキストを列H1：K1の対応する製品シートにコピーしています。このテキストは各製品シートのヘッダーとして機能するため、ヘッダーは各製品で同じではありません。各製品のテキストは、正しい製品シートにコピーする必要があります。

第2行に値があるため、第1行に添付されたテキストを列 'A'の各商品に対してコピーする際に問題があります。書式はすべての製品で同じです（2行 - テキストの最初の行と2行目）。

挑戦（私は惨めに失敗しました）は、特定の製品ごとにB：E列にコードコピーテキストを作成することです。 テキストは頻繁に変更することができます。その場合、コードが列 'A'の商品を識別して、幻想的なテキストをコピーして貼り付けることができます。

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

これは役立ちます。ヘッダー行では何もしませんでした。私はなぜそれを1つずつ変更しなければならないのか分からないからです。

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 

私はいくつかのメッセージを追加しました。あなたが戻ってくるものを教えてください。サンプルデータのダウンロードリンクを提供できますか？