Скопируйте данные из нескольких файлов Excel в мастер-файл

В настоящее время я новичок, когда дело доходит до VBA, и у меня есть проблема, которая требует эксперта в этой области. Итак, у меня есть именованный архив мастер-файла с кнопкой «Извлечь», и у меня есть несколько книг Excel (20+) в папке. Я хотел скопировать определенную информацию из этой книги и вставить ее в свой мастер-файл непрерывно в следующую пустую ячейку.

Не уверен, что не работает, надеюсь, что кто-то действительно может помочь мне в этом. знак равно

Sub CopyRows()

    ' Source
    Const sFolderPath As String = "C:\Users\ChrisLacs\Desktop\My Files - Copy\"
    Const sFilePattern As String = "*.xlsm*"
    Const sName As String = "Sheet1"
    'Const sAddress As String = "B9:N9"
    ' Destination
    Const dCol As String = "B"

    Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
    If Len(sFileName) = 0 Then
        MsgBox "No files matching the pattern '" & sFilePattern _
             & "'" & vbLf & "found in '" & sFolderPath & "'.", vbExclamation
        Exit Sub
    End If

    Dim dwb As Workbook: Set dwb = Sheet4.Parent
    Dim dFileName As String: dFileName = dwb.Name
    Dim dCell As Range
    
    'Dim drg As Range
    'Set drg = dCell.Resize(, Sheet4.Range(sAddress).Columns.Count)

    Application.ScreenUpdating = False

    Dim swb As Workbook
    Dim sws As Worksheet
    'Dim srg As Range
    Dim fCount As Long

    fCount = 0
    
    Do Until Len(sFileName) = 0
        If StrComp(sFileName, dFileName, vbTextCompare) <> 0 Then
            Set swb = Workbooks.Open(sFolderPath & sFileName)
            On Error Resume Next                 ' attenpt to reference the source worksheet
            Set sws = swb.Worksheets(sName)
            On Error GoTo 0
            
            
            If Not sws Is Nothing Then
            
                Set dCell = Sheet1.Cells(SProd.Rows.Count, dCol).End(xlUp).Offset(1)
            
                With sws.Range("B8" & sws.Range("B:N").Find("*", , xlValues, , xlByRows, xlPrevious).Row)
    
                    .AutoFilter 8, "Funded"
        
                    On Error Resume Next
                    .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Copy dCell
                    On Error GoTo 0
                    
                    fCount = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 + fCount
                    
                    .AutoFilter
                    
                End With
            
            
            
                ' source worksheet found
                'Set srg = sws.Range(sAddress)
                ' Either copy values, formulas, formats...
                'srg.Copy drg
                ' ... or instead copy only values (more efficient (faster))
                'drg.Value = srg.Value
                'Set drg = drg.Offset(1)
                Set sws = Nothing
                
            Else                                 ' source worksheet not found; do nothing
            End If
            swb.Close SaveChanges:=False
        End If
        sFileName = Dir
    Loop

    Application.ScreenUpdating = True

    MsgBox "Rows copied: " & fCount, vbInformation

End Sub

Не могли бы вы поделиться тем, что должно быть rw: вы объявили его как диапазон, но ничего ему не присваиваете, то есть это Nothing, а строка If rw.Columns("J").Value = "Apple" Then вызовет ошибку. Также отсутствует «закрытие» End If.

VBasic2008 15.05.2022 05:44

моя вина. Да. Я обновил свои коды. В основном это незаконченные коды. Просто хотел узнать, как работает извлечение из нескольких файлов Excel в мой мастер-файл.

Xlacssss 15.05.2022 06:02
Преобразование HTML-таблицы в профессиональный документ Excel
Преобразование HTML-таблицы в профессиональный документ Excel
Это самый простой способ создания Excel из HTML-таблицы.
Импорт excel в laravel в базу данных
Импорт excel в laravel в базу данных
Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...
2
2
47
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Скопируйте диапазон строк из нескольких книг

Sub CopyRows()
    
    ' Source
    Const sFolderPath As String = "C:\Users\ChrisLacs\Desktop\My Files\"
    Const sFilePattern As String = "*.xls*"
    Const sName As String = "Sheet1"
    Const sAddress As String = "B9:N9"
    ' Destination
    Const dCol As String = "A"
    
    Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
    If Len(sFileName) = 0 Then
        MsgBox "No files matching the pattern '" & sFilePattern _
            & "'" & vbLf & "found in '" & sFolderPath & "'.", vbExclamation
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = Sheet1.Parent
    Dim dFileName As String: dFileName = dwb.Name
    Dim dCell As Range
    Set dCell = Sheet1.Cells(Sheet1.Rows.Count, dCol).End(xlUp).Offset(1)
    Dim drg As Range
    Set drg = dCell.Resize(, Sheet1.Range(sAddress).Columns.Count)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim fCount As Long
    
    Do Until Len(sFileName) = 0
        If StrComp(sFileName, dFileName, vbTextCompare) <> 0 Then
            Set swb = Workbooks.Open(sFolderPath & sFileName)
            On Error Resume Next ' attenpt to reference the source worksheet
                Set sws = swb.Worksheets(sName)
            On Error GoTo 0
            If Not sws Is Nothing Then ' source worksheet found
                Set srg = sws.Range(sAddress)
                ' Either copy values, formulas, formats...
                srg.Copy drg
                ' ... or instead copy only values (more efficient (faster))
                'drg.Value = srg.Value
                Set drg = drg.Offset(1)
                Set sws = Nothing
                fCount = fCount + 1
            'Else ' source worksheet not found; do nothing
            End If
            swb.Close SaveChanges:=False
        End If
        sFileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "Rows copied: " & fCount, vbInformation
    
End Sub

Ух! Спасибо тебе за это! Это работает как шарм.. Всего несколько вопросов, в моих нескольких файлах в столбце J. У меня есть раскрывающийся список статуса. Как мне скопировать только тот статус, который = Работает, и исключить все элементы, которые не = Работают.. Также есть ли способ, как исключить все элементы, скопированные при следующем извлечении?

Xlacssss 15.05.2022 06:42

Возможно, вы захотите изучить AutoFilter, чтобы скопировать только отфильтрованные данные. Чтобы исключить уже скопированные данные, вы можете добавить столбец «флаг», чтобы записать в него флаг, например. «Да», когда строка уже скопирована. Конечно, вы учтете эту колонку в части AutoFilter. Это все выходит за рамки этого вопроса. Лучше спросите еще один и добавьте как можно больше деталей.

VBasic2008 15.05.2022 07:35

Привет, спасибо за предложение .. На самом деле я понятия не имею .. Я думаю добавить еще одну ячейку в мой мастер-файл. Поле даты, поэтому, когда я набираю дату в ячейке. (например, A1 = 21 мая). Все 21 мая в тех книгах будут извлечены. Просто не знаю с чего начать. Не могли бы вы помочь мне с моими текущими кодами, предоставленными VBasic2008? знак равно

Xlacssss 15.05.2022 17:57

Другие вопросы по теме