如何使用Excel宏從列中提取值到另一個工作表

Question

我想在新工作表（sheet2）列中提取所有“發票”值。 現在，我只能從“發票”中獲取單個值（而不能獲取所有值）。

請找到以下代碼：

Sub MergeData()

a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a    
    If Worksheets("Sheet1").Cells(i, 4).Value = "Rechnungen / invoices" Then 

        Worksheets("Sheet1").Cells(i + 2, 4).Copy
        Worksheets("Sheet2").Activate
        b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets("Sheet2").Cells(b + 1, 3).Select
        ActiveSheet.Paste
        Worksheets("Sheet1").Activate          
    End If
Next
End Sub

實際上，我是宏的初學者，我不知道如何添加循環和條件來獲取所有值。

布局：

Answer 1

這是循環的一種方式。 我通過找到文本的位置定義行邊界。

最小行約束：

發票將位於包含"Rechnungen / invoices"的單元格之后

Set startCell = .Columns("D").Find("Rechnungen / invoices")

最大行約束：

發票將在包含"Anzahl/ Quantity"的單元格之前停止

Set endCell = .Columns("D").Find("Anzahl/ Quantity")

左右約束：

發票在D和F列之間。

只有以下值的單元格：

.SpecialCells(xlCellTypeConstants)

---

Option Explicit
Public Sub Test()
    Application.ScreenUpdating = False
    Dim invoices As Object, currentCell As Range, startCell As Range, endCell As Range, loopRange As Range
    Set invoices = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Worksheets("Sheet1")
        Set startCell = .Columns("D").Find("Rechnungen / invoices")
        Set endCell = .Columns("D").Find("Anzahl/ Quantity")
        If startCell Is Nothing Or endCell Is Nothing Then Exit Sub
        If startCell.Row > endCell.Row Then Exit Sub
        Set loopRange = .Range("D" & startCell.Row + 1 & ":F" & endCell.Row - 1)
        If Application.WorksheetFunction.CountA(loopRange) = 0 Then Exit Sub
        For Each currentCell In loopRange.SpecialCells(xlCellTypeConstants)
            If Not invoices.exists(currentCell.Value) Then invoices.Add currentCell.Value, 1
        Next currentCell

        ThisWorkbook.Worksheets("Sheet2").Range("A1").Resize(invoices.Count, 1) = Application.WorksheetFunction.Transpose(invoices.keys)
    End With
    Application.ScreenUpdating = True
End Sub

Answer 2

下面的代碼也有效

Sub MergeData()
a = Worksheets("Tabelle1").Cells(Rows.count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Tabelle1").Cells(i, 4).Value = "Rechnungen / invoices" Then
        c = 0
        For k = 4 To 6
            For J = 2 To 6
                If (IsNumeric(Worksheets("Tabelle1").Cells(i + J, k))) Then
                    Worksheets("Tabelle1").Cells(i + J, k).Copy
                    Worksheets("Tabelle2").Activate
                    b = Worksheets("Tabelle2").Cells(Rows.count, 1).End(xlUp).Row
                    Worksheets("Tabelle2").Cells(b + c, 3).Select
                    c = c + 1
                    ActiveSheet.Paste
                    Worksheets("Tabelle1").Activate
                End If
            Next
        Next
    End If
Next

End Sub