回圈遍歷所有單元格，檢查單元格值是否為X然后將單元格復制到不同位置

我目前有一個包含一列和十億行文本的 CSV 檔案 - 這些行中有很多填充物、絨毛和不必要的文本，但還有一個重復的模式我想檢查并復制到另一張紙上。

CSV 看起來像這樣：

我需要檢查“過濾器值”單元格中的特定字串，如果匹配，則使用過濾器值、高于值和低于值填充不同作業表中的表格，如下所示：

我目前擁有的代碼看起來像這樣，但它沒有將上面/下面的值放在正確的位置：

Sub CopyRecords()

Dim FilterCol As Range
Dim Filter As Range
Dim PasteCell As Range
Dim PasteCellAbove As Range
Dim PasteCellBelow As Range

' Clear Destination table for testing
ThisWorkbook.Sheets(2).Range("A2:C999").Clear

Set FilterCol = ThisWorkbook.Sheets(1).Range("A1:A999")

For Each Filter In FilterCol

    If ThisWorkbook.Sheets(2).Range("A2") = "" Then
        Set PasteCell = ThisWorkbook.Sheets(2).Range("A2")
        Set PasteCellAbove = ThisWorkbook.Sheets(2).Range("B2")
        Set PasteCellBelow = ThisWorkbook.Sheets(2).Range("C2")
    Else
        Set PasteCell = ThisWorkbook.Sheets(2).Range("A1").End(xlDown).Offset(1, 0)
        Set PasteCellAbove = ThisWorkbook.Sheets(2).Range("B1").End(xlDown).Offset(1, 0)
        Set PasteCellBelow = ThisWorkbook.Sheets(2).Range("C1").End(xlDown).Offset(1, 0)
    End If

    If Left(Filter, 5) = "Testo" Then
        Range(Filter.End(xlToLeft), Filter.End(xlToRight)).Copy PasteCell
        Range(Filter.Offset(1, 0), Filter.Offset(0, 0)).Copy PasteCellAbove
        Range(Filter.Offset(-1, 0), Filter.Offset(0, 0)).Copy PasteCellBelow
    End If
Next Filter
        
End Sub

有誰可以伸出援手嗎？

uj5u.com熱心網友回復：

試試這個 - 只要有可能，處理資料陣列的速度就會快得多。

Sub CopyRecords()

    Dim data, r As Long, rwOut As Range, v
    
    'get all data as an array
    With ThisWorkbook.Sheets(1)
        data = ThisWorkbook.Sheets(1).Range("A1:A" & _
                   .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With
    
    With ThisWorkbook.Sheets(2)        'reporting sheet
        .Range("A2:C999").Clear        'clear destination table
        Set rwOut = .Range("A2:C2")    'first row of output
    End With
    
    For r = 2 To UBound(data, 1) - 1
        v = Trim(data(r, 1))
        If v Like "*email:*" Then
            rwOut.Value = Array(v, data(r - 1, 1), data(r   1, 1)) 'write values
            Set rwOut = rwOut.Offset(1, 0)                         'next row down
        End If
    Next r
End Sub

uj5u.com熱心網友回復：

如果您的輸入檔案中真的有十億行，我認為您不會想要在 Excel 作業表中打開它來處理它。
這是一個打開 TextStream 物件并逐行讀取源檔案而不是將其全部讀入記憶體的解決方案。
它將輸出轉儲到 Excel 檔案中的新作業表中，但取決于您的輸出有多大，我想知道您是否最終可能想要將其寫入 CSV 檔案。

無論如何，這是一個潛在的解決方案。請注意，我沒有對“之前”和“之后”行進行任何決議。

Option Explicit


Public Sub extractData()
    Const sourceName As String = "c:\apps\excel\so demo\input.csv" 'change this as necessary
    Const maxOutputRecs As Long = 10000000
    
    Dim fso As Scripting.FileSystemObject
    Dim ts As Scripting.TextStream
    Dim before, after, cLine As String
    Dim n, i As Long
    Dim xlSheet As Excel.Worksheet
    Dim rng As Excel.Range
    
    
    Dim data() As Variant
    ReDim data(1 To maxOutputRecs, 1 To 3)
    
    'Add header line to output array
    data(1, 1) = "Testo"
    data(1, 2) = "Before"
    data(1, 3) = "After"
    
    Set fso = New Scripting.FileSystemObject
    Set ts = fso.OpenTextFile(Filename:=sourceName, IOMode:=ForReading, Create:=False)

    i = 0
    n = 0
    cLine = ""
    'read through source file line by line
    Do While Not ts.AtEndOfStream
        i = i   1
        before = cLine
        cLine = ts.ReadLine
        If VBA.Left(cLine, 5) = "Testo" Then
            n = n   1
            after = ts.ReadLine
            data(n   1, 1) = cLine
            data(n   1, 2) = before
            data(n   1, 3) = after
            cLine = after
        End If
        
        If n   1 = maxOutputRecs Then
            'end loop - may want to throw an error or write to a log file or do something else
            Exit Do
        End If
    Loop
    
    ts.Close
    
    data = redim2DArrayRows(data, n   1, 3)
    
    'create a new worksheet for the output
    Set xlSheet = ThisWorkbook.Worksheets.Add
    xlSheet.Name = "output"
    'define the output range in the worksheet based on array size
    Set rng = xlSheet.Range( _
        xlSheet.Cells(1, 1), _
        xlSheet.Cells(UBound(data, 1), UBound(data, 2)) _
        )
    'Write data out to sheet
    rng.Value = data
    
    
End Sub



Public Function redim2DArrayRows(ByRef sourceArray() As Variant, ByVal rowBound As Long, ByVal colBound As Long) As Variant()
    Dim newArr() As Variant
    Dim i As Long
    Dim j As Long
    
    ReDim newArr(LBound(sourceArray, 1) To rowBound, LBound(sourceArray, 2) To colBound)
    For i = LBound(newArr, 1) To UBound(newArr, 1)
        For j = LBound(newArr, 2) To UBound(newArr, 2)
            newArr(i, j) = sourceArray(i, j)
        Next j
    Next i
    redim2DArrayRows = newArr
End Function

uj5u.com熱心網友回復：

提取資料使用 FindNext

Option Explicit

Sub ExtractData()
    Const ProcTitle As String = "Extract Data"
    
    Const sCriteria As String = "Testo*" ' begins with ("*Testo*" contains)
    Const cCount As Long = 3 ' don't change: it's the same for source and dest.
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(1)
    Dim srg As Range
    ' Either static...
    Set srg = sws.Range("A2:A999") ' no cell above 'A1'
    ' ... or dynamic:
    'Set srg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    Dim sCell As Range
    Set sCell = srg.Find(sCriteria, srg.Cells(srg.Rows.Count), xlValues, xlPart)
    If sCell Is Nothing Then Exit Sub
    
    Dim FirstAddress As String: FirstAddress = sCell.Address
    Dim sTemp As Variant: ReDim sTemp(1 To cCount)
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(2)
    Dim dCell As Range: Set dCell = dws.Range("A2")
    Dim dColl As Collection: Set dColl = New Collection
    
    
    ' Write the 3 values to the Temp array and add the array to the collection.
    Do
        ' Modify here, if you don't need the complete cell contents.
        ' Cell
        sTemp(1) = sCell.Value
        ' Above
        sTemp(2) = sCell.Offset(-1).Value
        ' Below
        sTemp(3) = sCell.Offset(1).Value
        
        dColl.Add sTemp
        Set sCell = srg.FindNext(sCell)
    
    Loop Until sCell.Address = FirstAddress
    
    Dim drCount As Long: drCount = dColl.Count
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
    
    Dim Item As Variant
    Dim r As Long
    Dim c As Long
    
    ' Loop over the arrays in the collection and write the elements
    ' of each array to a row of the Destination array.
    For Each Item In dColl
        r = r   1
        For c = 1 To cCount
            dData(r, c) = Item(c)
        Next c
    Next Item
    
    ' Write the values of the Destination array to the Destination range.
    Dim drg As Range: Set drg = dCell.Resize(drCount, cCount)
    drg.Value = dData
    
    ' Clear the range below the Destination range.
    Dim dcrg As Range: Set dcrg = drg.Resize( _
        dws.Rows.Count - drg.Row - drCount   1).Offset(drCount)
    dcrg.Clear
    'Debug.Print drg.Address(0, 0), dcrg.Address(0, 0)
    
    MsgBox "Done.", vbInformation, ProcTitle

End Sub

標籤：擅长 vba

上一篇：我可以從excel中取出一個表格并在python中繪制一個直方圖嗎？

下一篇：行范圍VBAExcel