Результаты программы VBA, не идущие на текущий рабочий лист

Question

Я новичок в VBA. Основываясь на информации, которую я нашел на этом форуме, я смог успешно создать функциональный макрос, но с остальными остальными. Целью макроса является создание набора данных из каталога, полного файлов xls *. В основном работает. Большое спасибо тем, кто опубликовал то, с чего я начал.

Проблема в том, что каждый раз, когда я выполняю, он создает набор ответов в Sheet1 новой рабочей книги. Я хотел бы, чтобы ответ был установлен либо в текущий лист текущей книги, либо в качестве альтернативы перешел в лист данных «Данные» конкретной книги. В этом случае мне бы очень хотелось, чтобы ответ был установлен в файле xlsm, где находится макрос. Я не смог найти рабочее решение. Точнее, я не понимаю, почему это не пойдет на мой текущий рабочий лист по умолчанию, поскольку документация, похоже, указывает на то, что он должен.

Другой вопрос. В следующем коде для неофита относительно просто следовать/корректировать Sub-код. Однако может ли кто-нибудь объяснить (как правило) код частной функции? Хотя он работает, мне трудно понять технически то, что он делает.

Sub ReadDataFromAllWorkbooksInFolder() 
    Dim FolderName As String, wbName As String, r As Long, cValue As Variant 
    Dim fs, f, s 
    Dim wbList() As String, wbCount As Integer, i As Integer, Lead As Integer 
    Dim CheckIN As Date, CheckOUT As Date 
    Dim Total As Currency, Deposit As Currency, Balance As Currency, STax As Currency, CTax As Currency, TTax As Currency 
    Dim Rent As Currency, Pet As Currency, Cleaning As Currency, HotTub As Currency 
    Dim BookDate As Date, Origin As Date 



    FolderName = "C:\Users\Ken\Documents\Personal\Ferguson House\Contracts\Sample" 
    ' create list of workbooks in foldername' --- Comment 
    wbCount = 0 
    wbName = Dir(FolderName & "\" & "*.xls*") 
    While wbName <> "" 
     wbCount = wbCount + 1 
     ReDim Preserve wbList(1 To wbCount) 
     wbList(wbCount) = wbName 
     wbName = Dir 
    Wend 
    If wbCount = 0 Then Exit Sub 
     ' get values from each workbook' --- Comment 
     r = 1 
     Workbooks.Add 
     For i = 1 To wbCount 
      r = r + 1 
      House = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "I1") 
      Name = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c2") 
      Address = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c3") 
      Phone = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c4") 
      Fax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c5") 
      Email = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c6") 
      Total = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "d10") 
      Deposit = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "d11") 
      Balance = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "d12") 
      STax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c55") 
      CTax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c56") 
      TTax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c57") 
      Rent = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c51") 
      Pet = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i16") 
      Cleaning = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i14") 
      HotTub = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i15") 
      CheckIN = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i2") 
      CheckOUT = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "g44") 
      NIGHTS = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i3") 
      BookDt = FolderName & "\" & wbList(i) 
      BookDate = FileDateTime(BookDt) 
      Origin = Int(BookDate) 
      Lead = CheckIN - Origin 
      Cells(r, 1).Value = wbList(i) 
      Cells(r, 2).Value = House 
      Cells(r, 3).Value = Name 
      Cells(r, 4).Value = Address 
      Cells(r, 5).Value = Phone 
      Cells(r, 6).Value = Fax 
      Cells(r, 7).Value = Email 
      Cells(r, 8).Value = Total 
      Cells(r, 9).Value = Deposit 
      Cells(r, 10).Value = Balance 
      Cells(r, 11).Value = STax 
      Cells(r, 12).Value = CTax 
      Cells(r, 13).Value = TTax 
      Cells(r, 14).Value = Rent 
      Cells(r, 15).Value = Pet 
      Cells(r, 16).Value = Cleaning 
      Cells(r, 17).Value = HotTub 
      Cells(r, 18).Value = CheckIN 
      Cells(r, 19).Value = CheckOUT 
      Cells(r, 20).Value = NIGHTS 
      Cells(r, 21).Value = Origin 
      Cells(r, 22).Value = Lead 

     Next i 

     'Create Headers 
     Range("$A$1").Value = "Contract" 
     Range("$B$1").Value = "House #" 
     Range("$C$1").Value = "Name" 
     Range("$D$1").Value = "Address" 
     Range("$E$1").Value = "Phone" 
     Range("$F$1").Value = "Fax" 
     Range("$G$1").Value = "Email" 
     Range("$H$1").Value = "Total" 
     Range("$I$1").Value = "Deposit" 
     Range("$J$1").Value = "Balance" 
     Range("$K$1").Value = "St Tax" 
     Range("$L$1").Value = "Cty Tax" 
     Range("$M$1").Value = "Tot Tax" 
     Range("$N$1").Value = "Rent Only" 
     Range("$O$1").Value = "Pet Fee" 
     Range("$P$1").Value = "Cleaning" 
     Range("$Q$1").Value = "Hot Tub" 
     Range("$R$1").Value = "Check In" 
     Range("$S$1").Value = "Check Out" 
     Range("$T$1").Value = "Nights" 
     Range("$U$1").Value = "Book Dte" 
     Range("$V$1").Value = "Lead Time" 
     Range("A1:V1").Font.Bold = True 

End Sub 

Private Function GetInfoFromClosedFile(ByVal wbPath As String, _ 
    wbName As String, wsName As String, cellRef As String) As Variant 
    Dim arg As String 
    GetInfoFromClosedFile = "" 
    If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\" 
    If Dir(wbPath & "\" & wbName) = "" Then Exit Function 
    arg = "'" & wbPath & "[" & wbName & "]" & _ 
     wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1) 
    On Error Resume Next 
    GetInfoFromClosedFile = ExecuteExcel4Macro(arg) 
End Function 

Answer 1

Workbooks.Add создает новую книгу.

ООН-квалифицированный Cells объект, где вы присваиваете данные для «текущего» листа, всегда будет возвращаться к тому, что рабочий лист активный во время выполнения. Добавление книги делает эту книгу активной, и по умолчанию объект Sheet1 будет активен в этой книге.

Я подозреваю, что просто избавившись от Workbooks.Add будет решить эту проблему, но, возможно, потребуется дополнительно настроить явным образом активировать лист, на котором вы хотите код для размещения, такие как:

With ThisWorkbook.Sheets("YOUR SHEET NAME") ' ## MODIFY AS NEEDED! 
     .Cells(r, 1).Value = wbList(i) 
     .Cells(r, 2).Value = House 
     .Cells(r, 3).Value = Name 
     .Cells(r, 4).Value = Address 
     .Cells(r, 5).Value = Phone 
     .Cells(r, 6).Value = Fax 
     .Cells(r, 7).Value = Email 
     .Cells(r, 8).Value = Total 
     .Cells(r, 9).Value = Deposit 
     .Cells(r, 10).Value = Balance 
     .Cells(r, 11).Value = STax 
     .Cells(r, 12).Value = CTax 
     .Cells(r, 13).Value = TTax 
     .Cells(r, 14).Value = Rent 
     .Cells(r, 15).Value = Pet 
     .Cells(r, 16).Value = Cleaning 
     .Cells(r, 17).Value = HotTub 
     .Cells(r, 18).Value = CheckIN 
     .Cells(r, 19).Value = CheckOUT 
     .Cells(r, 20).Value = NIGHTS 
     .Cells(r, 21).Value = Origin 
     .Cells(r, 22).Value = Lead 
    End With 

ПРИМЕЧАНИЕ: Вам также нужно будет сделать то же самое с вашими назначениями заголовков.

Answer 2

Каждый раз, когда вы используете ссылку, например Cells(r, 1).Value или Range("$K$1").Value, что вы неявно говорите, вы хотите ActiveSheet.Cells(r, 1).Value или ActiveSheet.Range("$K$1").Value.

Решение этого вопроса - использовать полностью квалифицированные ссылки. Не позволяйте Excel предполагать что-либо.

Таким образом, вместо того, чтобы просто делать

Workbooks.Add 

ли

Dim myDestinationSheet As Worksheet 
Dim myDestinationWorkbook As Workbook 
Set myDestinationWorkbook = Workbooks.Add 
Set myDestinationSheet = myDestinationWorkbook.Sheets(1) 
myDestinationSheet.Name = "Data" 
myDestinationSheet.Cells(1,1).value = House 

Вы должны использовать эту технику, чтобы устранить любую возможную двусмысленность в объектных ссылок на каждой строке кода вы пишете. Даже если вы используете ActiveSheet, например, по умолчанию, лучше использовать его явно.

Answer 3

Функция - хороший подход - то, что делает, в основном сэкономит вам время на открытие желаемого WB и вместо этого прямое извлечение данных.
В «нормальном» процессе вам понадобится
1. Откройте WB
2. Выберите лист
3. Получите требуемое значение
4.Закройте WB
. Эти функции зависят от того, что вы можете ввести формулу в Excel, который извлекает желаемое значение из закрытого wb. Вы можете попробовать самостоятельно в ExcelSheet ='C:\MyUser\Documents\[DesiredWB.xls]Sheet1'!$A$2 -> это быстрее, чем делать 4 шага, упомянутые выше, нет?
Однако это похоже на «быстрое исправление».
Я столкнулся с подобной ситуацией и пришел с этим решением, которое в основном делает то же самое, но имеет больше ошибок обработки. -Я сделать пример для «дом»
1. Во-первых, проверьте требуемый лист существует в WB:

Function SheetExistsFDB(ShtName$, WbPath$) As Boolean 
Dim GV, ParentFolder$, FileName$, PD% 
'Split to folder and file name 

PD = InStrRev(WbPath, "\") 
ParentFolder = Left(WbPath, PD - 1) 
FileName = Mid(WbPath, PD + 1) 


' also can be used to get the value RV from a specified Row Col if you need it 
GV = ExecuteExcel4Macro("'" & ParentFolder & "\[" & FileName & "]" & ShtName & "'!R1C1") 
SheetExistsFDB = CStr(GV) <> "Error 2023" 
' MsgBox CStr(GV) 
End Function 

2. Используйте эту формулу, чтобы просто ввести формулу, как описано:

Sub WriteFormulasvalues(iFilePath As String, iFilename As String, iSheet As String, iRC As String, iRange As Range, Optional AdditionalText As String) 
myFormula = "='" & iFilePath & "[" & iFilename & "]" & iSheet & "'!" & iRC & "" 
    With iRange 
    .Formula = myFormula 
    .Value = AdditionalText & .Value 
    End With 
End Sub 

Поскольку все ваши переменные используют один и тот же имя листа, я хотел бы использовать что-то вроде

For i = 1 To wbCount 
Dim RealPath 
RealPath = FolderName & wbList(i) 
If SheetExistsFDB("Contract", RealPath) = True Then ' 1. If SheetExistsFDB(RealPath, "Contract") = True 
     r = r + 1 
     'House used as example correct others 
     Call WriteFormulasvalues(FolderName, wbList(i), "Contract", "R1C9", Cells(r, 2)) 'I used RC format so according to your code I1= R1C9 

     Name = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c2") 
     Address = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c3") 
     Phone = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c4") 
     Fax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c5") 
     Email = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c6") 
     Total = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "d10") 
     Deposit = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "d11") 
     Balance = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "d12") 
     STax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c55") 
     CTax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c56") 
     TTax = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c57") 
     Rent = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "c51") 
     Pet = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i16") 
     Cleaning = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i14") 
     HotTub = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i15") 
     CheckIn = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i2") 
     CheckOut = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "g44") 
     NIGHTS = GetInfoFromClosedFile(FolderName, wbList(i), "Contract", "i3") 
     BookDt = FolderName & "\" & wbList(i) 
     BookDate = FileDateTime(BookDt) 
     Origin = Int(BookDate) 
     Lead = CheckIn - Origin 
     Cells(r, 1).Value = wbList(i) 
     'Cells(r, 2).Value = House no longer needed since WriterFormulas does it 
     Cells(r, 3).Value = Name 
     Cells(r, 4).Value = Address 
     Cells(r, 5).Value = Phone 
     Cells(r, 6).Value = Fax 
     Cells(r, 7).Value = Email 
     Cells(r, 8).Value = Total 
     Cells(r, 9).Value = Deposit 
     Cells(r, 10).Value = Balance 
     Cells(r, 11).Value = STax 
     Cells(r, 12).Value = CTax 
     Cells(r, 13).Value = TTax 
     Cells(r, 14).Value = Rent 
     Cells(r, 15).Value = Pet 
     Cells(r, 16).Value = Cleaning 
     Cells(r, 17).Value = HotTub 
     Cells(r, 18).Value = CheckIn 
     Cells(r, 19).Value = CheckOut 
     Cells(r, 20).Value = NIGHTS 
     Cells(r, 21).Value = Origin 
     Cells(r, 22).Value = Lead 
End If ' 1. If SheetExistsFDB(RealPath, "Contract") = True 
    Next i 
Sub WriteFormulasvalues(iFilePath As String, iFilename As String, iSheet As String, iRC As String, iRange As Range, Optional AdditionalText As String) 
myFormula = "='" & iFilePath & "[" & iFilename & "]" & iSheet & "'!" & iRC & "" 
    With iRange 
    .Formula = myFormula 
    .Value = AdditionalText & .Value 
    End With 
End Sub