从多个Excel文件中提取特定单元格并将其编译为一个Excel文件 [英] Extracting specific cells from multiple Excel files and compile it into one Excel file
问题描述
我是VBA的新手,我想用它来完成一些艰巨而艰巨的任务.我有大量的Excel文件,其中包含数千行和几列.我需要按行搜索,并提取具有特定字符串的某些单元格.我已经拼凑了一些函数和代码,并且几乎可以使用它,但是我不断收到意想不到的结果,例如提取无关的数据或随机错误,因为我不太了解VBA语法.作为Excel的新手,我正在尽力调试此代码,但它仍然没有给我所需的结果.到目前为止,我的代码如下:
I'm new to VBA, and I'd like to use it to do some difficult and arduous tasks. I have a large amount of Excel files with thousands of rows and several columns. I need to search, by row, and extract certain cells with specific strings. I've pieced together some functions and code and I have almost got it to work but I keep getting unexpected results like irrelevant data being extracted or it random errors because I don't understand VBA syntax super well. As a newbie to Excel, I'm at my wits end debugging this code and it still not giving me the results I need. My code thus far is as follows:
Option Explicit
Sub ImportDataFromMultipleFiles()
Dim firstAddress As Variant
Dim filenames As Variant
Dim i As Long
Dim rFind As Range
Dim firstFile As String
Dim n As Long
Dim r As Range
Dim myArray() As Integer
ThisWorkbook.Activate
Application.ScreenUpdating = False
Range("a2").Select
filenames = Application.GetOpenFilename _
(FileFilter:="Excel Filter(*xlsx), *.xlsx", MultiSelect:=True)
Application.FindFormat.Clear
For i = 1 To UBound(filenames) 'counter for files
firstFile = filenames(i)
Workbooks.Open firstFile 'Opens individual files in folder
n = 0
With ActiveSheet.UsedRange
Set rFind = .Find("Test*Results:", Lookat:=xlPart, MatchCase:=True, SearchFormat:=False)
If Not rFind Is Nothing Then
firstAddress = rFind.Address
Do
n = n + 1
Set rFind = .FindNext(rFind)
Selection.Copy
ThisWorkbook.Activate
Selection.PasteSpecial
ActiveCell.Offset(0, 1).Activate
Loop While Not rFind Is Nothing And rFind.Address <> firstAddress
End If
End With
ReDim myArray(0, n)
n = 0
Workbooks.Open firstFile 'Opens individual files in folder
With ActiveSheet.UsedRange
Set rFind = .Find("Test*Results:", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
firstAddress = rFind.Address
Do
myArray(0, n) = rFind.Row '<<< Error currently here
n = n + 1
Set rFind = .FindNext(rFind)
Selection.Copy
ThisWorkbook.Activate
Selection.PasteSpecial
ActiveCell.Offset(0, 1).Activate
Loop While Not rFind Is Nothing And rFind.Address <> firstAddress
End If
End With
For n = LBound(myArray) To UBound(myArray)
Debug.Print "Rows are: " & myArray(0, n)
Next n
Workbooks.Open filenames(i)
ActiveWorkbook.Close SaveChanges:=False
ActiveCell.Offset(1, 0).Activate
Next i
End Sub
我什至不确定第二个循环是否必要,但是使用它可以使我获得到目前为止我所寻找的最接近的结果.这段代码将覆盖大量数据,因此,任何使我的代码更加高效的建议也将不胜感激. 预先感谢!
I'm not even sure if the second loop is necessary, but using it has given me the closest results for what I'm looking for thus far. This code is going to cover a lot of data, so any suggestions to make my code more efficient as well will be much appreciated. Thanks in advance!
推荐答案
您绝对不需要所有这些代码.
You definitely don't need all that code.
尝试一下-如果将查找"部分拆分为单独的方法,则管理起来会更容易.
Try this out - it's easier to manage if you split out the "find" part into a separate method.
Option Explicit
Sub ImportDataFromMultipleFiles()
Dim filenames As Variant, wb As Workbook
Dim rngDest As Range, colFound As Collection, f, i As Long
Set rngDest = ActiveSheet.Range("A2") '<< results start here
filenames = Application.GetOpenFilename( _
FileFilter:="Excel Filter(*xlsx), *.xlsx", MultiSelect:=True)
If TypeName(filenames) = "Boolean" Then Exit Sub '<< nothing selected
Application.FindFormat.Clear
For i = 1 To UBound(filenames) 'counter for files
Set wb = Workbooks.Open(filenames(i))
Set colFound = FindAll(wb.Sheets(1).UsedRange, "Test*Results:") '<< get matches
Debug.Print "Found " & colFound.Count & " matches in " & wb.Name '<<EDIT
For Each f In colFound
f.Copy rngDest
Set rngDest = rngDest.Offset(1, 0)
Debug.Print "", f.Value
Next f
wb.Close False
Next i
End Sub
Public Function FindAll(rng As Range, val As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
这篇关于从多个Excel文件中提取特定单元格并将其编译为一个Excel文件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!