遍历所有单元格，检查单元格值是否为X，然后将单元格复制到不同的位置

我有一个CSV文件，只有一列和十亿行文本。在这些行中有很多填充，绒毛和不必要的文本，但也有一个重复的模式，我想复制到另一个工作表。

CSV看起来像这样:

tbody><<<

试试这个-只要可能，使用数据数组会快得多。

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

如果你的输入文件中真的有十亿行，我认为你不会想要在Excel工作表中打开它来处理它。
这是一个解决方案，打开一个TextStream对象，逐行读取源文件，而不是把它全部读入内存。
它将输出转储到Excel文件中的新工作表中，但根据输出的大小，我想知道您最终是否希望将其写入CSV文件。

无论如何，这里有一个潜在的解决方案。注意，我没有对"before"进行任何解析。和";After"行。

Option Explicit

Public Sub extractData()
Const sourceName As String = "c:appsexcelso demoinput.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

使用`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

使用`FindNext`提取数据

相关内容

最新更新

热门标签：

列A
绒毛
以上价值/td>
过滤值
低于价值/td>
绒毛

遍历所有单元格，检查单元格值是否为X，然后将单元格复制到不同的位置

使用FindNext提取数据

相关内容

最新更新

热门标签：

使用`FindNext`提取数据