VBA程序结果不转到当前工作表

Question

我是VBA的新手。根据我在这个论坛中发现的信息，我已经能够成功创建功能宏，但剩下一些问题。宏的目的是从装满XLS*文件的目录构建数据集。主要工作得很好。非常感谢那些发布我开始的内容的人。

问题是，每次执行时，都会在新工作簿的Sheep1中创建答案集。我希望答案设置可以进入当前工作簿的当前表，或者进入特定工作簿的"数据"表。在这种情况下，我真的很想让答案设置在宏所在的XLSM文件中。我无法找到工作解决方案。更准确地说，我不明白为什么默认情况下这不会到我当前的工作表，因为文档似乎表明应该是。

另一个问题。在以下代码中，新手遵循/调整子代码相对简单。但是，有人可以解释（通常）私人功能代码吗？尽管它有效，但我很难从技术上了解它在做什么。

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:UsersKenDocumentsPersonalFerguson HouseContractsSample"
    ' 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对象将始终恢复到运行时的任何工作表 Active 。添加一个工作簿使该书活跃，默认情况下，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. close wb
此功能取决于您可以在Excel中键入一个从封闭的WB中检索所需值的公式。您可以在ExcelSheet ='C:MyUserDocuments[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