Как использовать «НАЙТИ» в качестве первой и последней строки для просмотра значения, сопоставления значения и копирования соседней ячейки в другую книгу?

Question

Я застрял с ошибкой несоответствия типов 13 при операторе поиска.Поскольку данные в моих книгах не расположены в предсказуемом месте, мне нужно сначала найти «От:» и искать «Серийный номер» в качестве исходных номеров непосредственно перед поиском «Кому:».После заполнения Source или From Serial Nos мне нужно скопировать и в 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

Так как иногда родителей много, а ребенок один или мало, я ставлю 1 на А1 и увеличиваю на 1 для каждой строки, записанной вРодительские или дочерние столбцы для получения последней строки, а не для смешивания вывода данных.Я пытаюсь поместить имя файла в столбец назначения B, и "From:" или родительский серийный номер или серийные номера в столбце C и "To:" серийный номер или серийные номера в качестве дочерних серийных номеров в столбце D. Я создалмакрос, который активирует A14 (всегда есть «Form:») и находит текст «Serial No» и копирует следующую ячейку с действительным серийным номером, пока «To:» не будет найден в ячейке в A: A где-то там дляпример А30 или А40.После того, как я нахожу «To:», я использую find «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, пропуская текст «Серийный номер» и пустые ячейки и перенося их в рабочую таблицу («сортировщик») вместе с именем файла.Я не чувствовал особой важности использования метода find.

В этом случае вы можете попробовать приведенный ниже упрощенный код перебора (поскольку вы утверждаете, что только ячейки от A14 до A40 содержат важные данные).Однако для лучшего понимания проблем можно привести несколько хороших примеров метода Find и его параметров. Также старайтесь избегать активации и т. Д. И позаботьтесь о циклах с четким представлением о том, чего вы хотите достичь.

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