如何使用“FIND”作为第一行和最后一行来查看值，匹配值并将相邻单元格复制到另一个工作簿？

Question

我在 Find 运算符上遇到了类型不匹配错误 13。 由于我的工作簿上的数据未放置在可预测的位置，我需要先找到“发件人：”，然后在查找“收件人：”之前查找“序列号”作为源编号。 完成 Source 或 From Serial Nos 后，我也需要复制 To Serial numbers。 对于我这样的新手来说难度不大。

我在文件夹的子文件夹中有数千个带有单个工作表的 Excel 工作簿，我想使用 VBA 将相关数据复制到另一个工作簿。 Excel 工作表在 A14“来自：”包含一个或多个序列号作为父序列号及其多个子序列号，例如在 A16 1234345 中，以便可以跟踪序列号是从哪个...父母给很多孩子或从很多父母来巩固一个。 数据采用不太组织的excel表格。

From:         Or From
Serial No        Serial No  
12365            521466
                 541852
To:              752142
Serial No     
12435             To:
34562            Serial No
23645            548215

应该：

1 File1  From: 12365 To: 12435 34562 23645
2 File   From: 12435 34562 23645 To: 548215

有时，父母很多，孩子是单身或少数，我在 A1 处不加 1，并为在父列或子列中写入的每一行增加 1 以导出最后一行而不是混合数据输出。 我试图将文件名放在目标 B 列中，并将“发件人：”或父序列号或序列号放在 C 列和“收件人：”序列号或序列号作为 Col D 中的子序列号。我创建了一个激活 A14 的宏（总是有“表格：”）并找到文本“序列号”并复制下一个具有实际序列号的单元格，直到在 A:A 的某个单元格中找到“收件人：”例如 A30 或 A40。 之后，我找到“收件人：”，我使用查找“序列号”并在下一个单元格中复制实际序列号并粘贴到 D 列

 Sub NewTry555()

Dim File As Variant
Dim fileList As Collection
Dim RootFolder As String
Dim wbk As Workbook
Dim sh1 As Worksheet
Dim wbk2 As Workbook
Dim sh2 As Worksheet
Dim findcell As Range

Set fileList = New Collection


RootFolder = "C:\Users\Bota\Desktop\TestVba\Folder1\"


File = Dir(RootFolder & "*.xl*")

 While File <> ""

'Add File to Collection
    fileList.Add RootFolder & File
    File = Dir
 Wend

Dim FilePath As Variant

Dim objBasis As Workbook
Dim objReport As Workbook

Set objBasis = ThisWorkbook

 For Each FilePath In fileList

Set objReport = Workbooks.Open(FilePath)

Set wbk = ActiveWorkbook
Set sh1 = wbk.Sheets(1)

Dim rng As Range
Dim i As Long

With sh1

End With

Set wbk2 = ThisWorkbook

Set sh2 = wbk2.Sheets("Sorter")

Dim lastrow1 As Long
Dim Filename As String
Filename = Dir(FilePath)

sh2.Activate

With sh2
 lastrow1 = Cells(Rows.Count, 1).End(xlUp).Row
 ActiveSheet.Range("A" & lastrow1).Offset(1).Formula = 1
 ActiveSheet.Range("B" & lastrow1).Formula = Filename
End With

 Dim LastRangeSearch As Range
sh1.Activate
With ActiveSheet
Cells.Select
Selection.UnMerge

lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A12").Activate
For i = 2 To lastrow
 Set rng = sh1.Range("A14" & i)
 Set LastRangeSearch = sh1.Range("A" & i).Find(What:="To:", 
After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, 
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, 
SearchFormat:=False)

 Next
 sh1.Range("A14").Activate
 rollno = "*Serial No*"
 Do Until LastRangeSearch
 findcell = rng.Find(What:=rollno, After:=ActiveCell, 
 LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, 
 SearchDirection:=xlNext, MatchCase:= _
True, SearchFormat:=False)


For Each findcell In rng

If Not findcell Is Nothing Then
findcell.Offset(1).Copy
sh2.Range("A" & lastrow1).Offset(0, 3).PasteSpecial xlPasteValues

End If

Next
Loop

End With

sh1.Activate
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
 LastRangeSearch.Activate

 Do Until sh1.UsedRange("A" & lastrow)

findcell = rng.Find(What:=rollno, After:=ActiveCell, LookIn:=xlFormulas, 
 LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, 
MatchCase:= True, SearchFormat:=False)


For Each findcell In rng

If Not findcell Is Nothing Then
findcell.Offset(1).Copy
sh2.Range("A" & lastrow1).Offset(0, 4).PasteSpecial xlPasteValues

End If


Next
Loop


wbk.Close savechanges:=False

Next FilePath

End Sub

Answer 1

代码似乎存在多个问题。 但是我从您的要求中了解到，基本上您试图将 A14 复制到最大大约 A40，跳过文本“序列号”和空单元格并将它们与文件名一起转入工作表（“排序器”）。 我感觉不到使用 find 方法的重要性。

如果是这种情况，您可以尝试以下简化的蛮力代码（因为您声称只有单元格 A14 到 A40 包含重要数据）。 然而，为了更好地理解问题，可以通过 Find Method 及其参数的一些很好的例子。也尽量避免激活等，并在清楚地了解你和实现的目标的情况下照顾循环。

Sub NewTry555()
Dim File As String
Dim RootFolder As String
Dim wbk As Workbook
Dim Sh As Worksheet
Dim wbk2 As Workbook
Dim sh2 As Worksheet
Dim LastRow As Long, LastRow2 As Long, Rw As Long, OfSt As Long
Dim FileNum As Long, Txt As String

RootFolder = "C:\Users\User\Desktop\Folder1\"
Set wbk2 = ThisWorkbook
Set sh2 = wbk2.Sheets("Sorter")
lastrow1 = sh2.Cells(Rows.Count, 1).End(xlUp).Row


File = Dir(RootFolder & "*.xl*")
FileNum = 0

    While File <> ""
    FileNum = FileNum + 1
    Set wbk = Workbooks.Open(RootFolder & File)
    Set Sh = wbk.Sheets(1)
    Sh.Cells.UnMerge
    LastRow = Sh.Cells(Rows.Count, 1).End(xlUp).Row

    lastrow1 = lastrow1 + 1
    sh2.Range("A" & lastrow1).Offset(1).Value = FileNum
    sh2.Range("B" & lastrow1).Value = File
    OfSt = 0
        For Rw = 14 To LastRow
        Txt = Sh.Cells(Rw, 1).Text
            If Len(Txt) > 0 Then
            If InStr(1, Txt, "Serial No") <= 0 Then
            OfSt = OfSt + 1
            sh2.Range("B" & lastrow1).Offset(, OfSt).Value = Txt
            End If
            End If
        Next
    wbk.Close False
    File = Dir
    Wend

End Sub