如果某些条件为真，则仅将特定的单元复制到不同的床单

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循环来查找产品，然后在右侧的每个列中的每个列中的每个列中的文本复制到列H1：K1中的相应产品表中。该文本充当每个产品表的标题，因此每个产品的标题都不相同。每个产品的文本必须复制到正确的产品表中。

我在第一排中附加在" a"列中的每个产品的文本时遇到问题，因为第二行具有值。所有产品的格式相同 - 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

这应该有所帮助。我没有对标头行做任何事情，因为我不知道为什么您必须更改它，更不用说每次记录一次了。

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

我添加了几条消息来查看发生了什么。让我知道你回来了。您可以提供带有示例数据的下载链接吗？