Question

我在查找运算符上遇到类型不匹配错误13的困扰。由于工作簿上的数据没有放置在可预测的位置，因此我需要先找到“发件人：”，然后在找到“收件人：”之前寻找“序列号”作为源编号。完成“源”或“从序列号”后，我也需要复制到“序列号”。对于像我这样的新手来说有点难。

我有数千个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中，并将“收件人：”序列号或序列号作为子句序列号作为列D中的子序列号。激活A14的宏（总是有“ Form：”）并找到文本“ Serial No”并复制具有实际序列号的下一个单元格，直到在A：A的某个单元格中找到“ To：”为止例如A30或A40。之后，找到“ To：”，然后使用“ Serial No”并在下一个单元格中复制实际的序列号，然后粘贴到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左右，跳过文本“序列号”和空单元格，并将它们与文件名一起转移到worksheet（“ sorter”）中。我对使用find方法没有太大的重视。

如果是这种情况，则可以尝试使用以下简化的蛮力代码（因为您仅声明单元格A14至A40包含有效数据）。但是，为了更好地理解问题，可能会通过“查找方法”及其参数的一些很好的例子。还应尽量避免激活等，并在清楚了解您要实现的目标的前提下处理循环。

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

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

1 个答案: