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＆＃39; A＆＃39;中使用了For循环。找到产品，然后将右边4列中每一列中的文本复制到H1：K1列的相应产品表中。此文本充当每个产品表的标题，因此每个产品的标题都不相同。必须将每个产品的文本复制到正确的产品表中。

我在第一行中针对每个产品复制第一行中附带的文字时遇到问题，因为第二行有值。所有产品的格式都相同--2行 - 文本的第一行和公式的第二行。

挑战（我失败了）是为每个特定产品制作B：E列中的代码复制文本。文本可以经常更改，因此如果代码可以在列A＆＃39; A＆＃39;中标识产品。并复制/粘贴那将是太棒了的文本。

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

我添加了一些消息，看看是什么。让我知道你得到了什么。您能提供包含样本数据的下载链接吗？

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

1 个答案: