Question

我正在搜索空白单元格列，如果找到空白单元格，那么我想复制与空白单元格相邻的前两个单元格并发布到新工作表。

blksArray是我正在搜索空白的列。

emailArray和nameArray是复制单元格的相邻列，如果在blksArray中找到空白

宏工作，但我希望我可以使用单个数组代替两个数组emailArray和nameArray

谢谢

编辑：抱歉，如果我感到困惑资料表：

Name    Emails            XXX
Bill    Bill@Bill.com     abc    
Tony    Tony@Tony.com
Roger   Roger@Roger.com   aaa
Diane   Diane@Diane.com   bbb
Pam     Pam@Pam.com
Barb    Barb@Barb.com
Ziggy   Ziggy@Ziggy.com   ddd

目标表：

Name    Emails            XXX 
Tony    Tony@Tony.com
Pam     Pam@Pam.com
Barb    Barb@Barb.com

代码：

Sub MoveCellsIfEmpty()
Dim blankArray As Variant, textArray As Variant
Dim wsS As Worksheet
Dim wsT As Worksheet
Dim LR As Long
Dim i As Long

Set wsS = ThisWorkbook.Sheets("NodeFile")
Set wsT = ThisWorkbook.Sheets("Blanks")

With wsS
    LR = .Range("A" & .Rows.Count).End(xlUp).Row

    '\\ search column
    blksArray = .Range("E2:E" & LR).Value

   '\\ Cells to copy
   emailArray = .Range("D2:D" & LR).Value
    nameArray = .Range("C2:C" & LR).Value

        For i = LBound(blksArray, 1) To UBound(blksArray, 1)
            If IsEmpty(blksArray(i, 1)) Then
               emailArray(i, 1) = emailArray(i, 1)
                nameArray(i, 1) = nameArray(i, 1)
            Else
                emailArray(i, 1) = ""
                 nameArray(i, 1) = ""
            End If
        Next i
End With

'\\ Post back to target sheet
With wsT
     .Range("A2:A" & LR).Value = nameArray
     .Range("B2:B" & LR).Value = emailArray
End With

End Sub

Answer 1

好的，我使用单个阵列重新编写答案。当你明确地将一个范围读入一个数组时，它创建了一个二维数组的电子表格坐标（谁知道！？）所以不是创建多个数组并将它们修剪下来或重新添加到一个新数组，我只是创建了如果第三个值为空，则通过将它们添加到新工作表中进行循环。我在104,000条记录上运行它，可能需要3到4秒。希望这更多地取决于你所追求的金钱：）

Sub MoveCellsIfEmpty()
Dim blankArray() As Variant
Dim wsS As Worksheet
Dim wsT As Worksheet
Dim LR As Long
Dim i As Long
Dim j As Long

Set wsS = ThisWorkbook.Sheets("NodeFile")
Set wsT = ThisWorkbook.Sheets("Blanks")

With wsS
    LR = (.Range("A" & .Rows.Count).End(xlUp).Row)
    blankArray = .Range("A2:C" & LR)
End With

j = 1
For i = 1 To LR - 1
     If blankArray(i, 3) = "" Then 'if blank paste to new sheet
        wsT.Range("A" & j).Value = blankArray(i, 1)
        wsT.Range("B" & j).Value = blankArray(i, 2)
        j = j + 1
     End If


Next


End Sub

在工作maco中使用一个2dim数组而不是两个1dim数组

1 个答案: