В настоящее время я новичок, когда дело доходит до 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
моя вина. Да. Я обновил свои коды. В основном это незаконченные коды. Просто хотел узнать, как работает извлечение из нескольких файлов Excel в мой мастер-файл.
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. У меня есть раскрывающийся список статуса. Как мне скопировать только тот статус, который = Работает, и исключить все элементы, которые не = Работают.. Также есть ли способ, как исключить все элементы, скопированные при следующем извлечении?
Возможно, вы захотите изучить AutoFilter
, чтобы скопировать только отфильтрованные данные. Чтобы исключить уже скопированные данные, вы можете добавить столбец «флаг», чтобы записать в него флаг, например. «Да», когда строка уже скопирована. Конечно, вы учтете эту колонку в части AutoFilter
. Это все выходит за рамки этого вопроса. Лучше спросите еще один и добавьте как можно больше деталей.
Привет, спасибо за предложение .. На самом деле я понятия не имею .. Я думаю добавить еще одну ячейку в мой мастер-файл. Поле даты, поэтому, когда я набираю дату в ячейке. (например, A1 = 21 мая). Все 21 мая в тех книгах будут извлечены. Просто не знаю с чего начать. Не могли бы вы помочь мне с моими текущими кодами, предоставленными VBasic2008? знак равно
Не могли бы вы поделиться тем, что должно быть
rw
: вы объявили его как диапазон, но ничего ему не присваиваете, то есть этоNothing
, а строкаIf rw.Columns("J").Value = "Apple" Then
вызовет ошибку. Также отсутствует «закрытие»End If
.