使用vba逐行条件复制和粘贴

Question

在@FaneDuru的宝贵帮助下，我可以使用以下代码分别复制和粘贴单元格内容（可以包括使用alt+enter的新行）并单独粘贴到另一张纸中的另一列，直到我将粗体部分添加到代码中。 我的目标是如果 C 列中存在“NONE”字符串，则对单元格内容进行排序。但我在这一行收到错误 1004。

Sub Sheet2_Button_Click()
Dim ws As Worksheet, lastR As Long, arr, arrSpl, arrFin, i As Long, j As Long, k As 
Long

Set ws = ActiveSheet
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row

arr = ws.Range("A1:A" & lastR).Value2
ReDim arrFin(1 To UBound(arr) * 15, 1 To 1)
For i = 1 To UBound(arr)
     If arr(i, 1) <> "" And **ws.Range(“C2:C”) = “NONE”** Then
         arrSpl = Split(arr(i, 1), vbLf)
         For j = 0 To UBound(arrSpl)
             k = k + 1
             arrFin(k, 1) = arrSpl(j)
         Next j
     End If
Next i
If k > 0 Then
 Worksheets(sheet1).Range("B:B").ClearContents
 Worksheets(sheet1).Range("B1").Resize(k, 1).Value2 = arrFin
End If
End Sub

Answer 1

请尝试下一个改编的代码。不要忘记使用您真实的目的地工作表名称：

Sub splitAndCopyInAnotherColumn()
   Dim ws As Worksheet, wDest As Worksheet, lastR As Long, arr, arrSpl, arrFin, i As Long, j As Long, k As Long
   
   Set ws = ActiveSheet: Set wDest = Worksheets("your destination sheet name") 'use here the CORRECT existing destination sheet name
   lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
   
   arr = ws.Range("A1:C" & lastR).Value2
   ReDim arrFin(1 To UBound(arr) * 15, 1 To 1)
   For i = 1 To UBound(arr)
        If arr(i, 1) <> "" And UCase(arr(i, 3)) = "NONE" Then
            arrSpl = Split(arr(i, 1), vbLf)
            For j = 0 To UBound(arrSpl)
                k = k + 1
                arrFin(k, 1) = arrSpl(j)
            Next j
        End If
   Next i
   If k > 0 Then
    wDest.Range("B:B").ClearContents
    wDest.Range("B1").Resize(k, 1).Value2 = arrFin
   End If
End Sub

请在测试后发送一些反馈。