Excel 当激活不起作用时，如何在子例程之间传递工作表和工作簿？

背景：

来自实验室的每日石油分析报告将从电子邮件中剥离到一个文件夹中。按日期保存在文件夹中，每个样本发送可能在1到20个样本之间，不是每个日期，而是一天中的任何时间。

*.csv

文件存储在一个日期文件夹中，文件与日期和时间一起保存。我从继承的VBA脚本中解构的部分

这些文件将被忽略，直到月底（有一个并行的

.pdf

报告，我们使用该报告立即对结果采取行动），然后将它们汇总到月度/连续报告中，以进行长期趋势分析（采样的每个引擎仅每两个月左右显示一次）。问题似乎是实验室更改了

.csv

报告

原始脚本采用了以常规格式显示的列（如在固定列中）。新报告具有动态列（如：如果没有任何样本的数据，则没有列）。更糟糕的是，当列出现时，它们改变了列的顺序。自动汇总报告用于遍历每个有日期的文件夹、提取每个文件并将其附加到主工作簿中，但它在垃圾数据中已不再具有意义

我觉得，最简单的解决方案是重建每个示例文件中的数据，方法是重建并重新格式化新工作表中的列（搜索列标题、错误捕获（如果不存在）、复制并粘贴、重新格式化/执行单位转换等），然后将新工作表复制到主工作表中，保存并关闭文件，然后重复下一个

我遇到的问题是，当我将文件名传递给打开新文件的子例程时，添加的每个图纸都在主文件中，随后的剪切粘贴操作失败（下标超出范围，或我最喜欢的400）。我按日期命名每本书，按页码命名每一页，但循环的重复激活让我迷路了

我认为我根据传递的名称错误地引用了表格。一定有更简单的办法。所有其他的例子似乎都有固定的名字（如果生活就是这么简单的话）

更新1： 忘了提到我在其中一个文件中原型化了电子表格构建，然后尝试将其作为子程序传输到这里。在那里分崩离析。我已经清理了很多继承的代码并节省了大量的时间，但这是我第一次尝试从原始工作表中操作另一个工作簿中的另一个工作表。同样，大多数示例都使用固定名称，这在这里不是一个选项

Sub CopyPasteOAP(bookname)

    Dim datarow As Long

    'Grabs index of last data entered to prevent overwrite
    ThisWorkbook.Activate
    Sheet1.Range("B2").Activate
    Range("B2").End(xlDown).Select
    datarow = ActiveCell.Row

    'Restructures the Data Columns into a new worksheet for copying
    Workbooks(bookname).Activate
    Worksheet.Add

    'Date Column
    Sheet1.Range("G1").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    Sheets.Select Sheet2
        Range("A1").Select
        ActiveSheet.Paste
    'Unit Column
    Sheets.Select Sheet1
        Range("B1").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    Sheets.Select Sheet2
        Range("B1").Select
        ActiveSheet.Paste
    'Enter in OAP
    Sheets.Select Sheet2
        Range("C1").Select
        ActiveCell.FormulaR1C1 = "OAP"
        Selection.Copy
        Range("C2:C50").Select
        ActiveSheet.Paste
    'Fault Description = Lab Comments
    Sheets.Select Sheet1
        Cells.Find(What:="Lab Comments", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    Sheets.Select Sheet2
        Range("D1").Select
        ActiveSheet.Paste
    'Severity Column
    Sheets.Select Sheet1
        Range("H1").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    Sheets.Select Sheet2
        Range("G1").Select
        ActiveSheet.Paste
    'Notes = Lab Recommendations
    Sheets.Select Sheet1
        Cells.Find(What:="Lab Recommendations", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    Sheets.Select Sheet2
        Range("L1").Select
        ActiveSheet.Paste
    'Fuel in Oil
    Sheets.Select Sheet1
        Range("BL1").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    Sheets.Select Sheet2
        Range("M1").Select
        ActiveSheet.Paste
    'Coolant in Oil
    Sheets.Select Sheet1
        Range("BP1").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    Sheets.Select Sheet2
        Range("N1").Select
        ActiveSheet.Paste
    Sheets.Select Sheet1

    'Copies from the new sheet
    'Application.Workbooks(bookname).Activate
    Sheets.Select Sheet1
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    'Pastes to the master copy
    Application.ThisWorkbook.Activate
    Sheet1.Range("A" & datarow + 1).Select

    'Paste Special, Match Destination Format
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

    'Adjusts Font (otherwise new is all neon green)
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With

    'Clears Clipboard because the prompt is annoying
    Application.CutCopyMode = False

    Application.Workbooks(bookname).Activate
    ActiveWorkbook.Close False

End Sub

---

下面是您的代码看起来如何“清理”——注意，不需要选择/激活任何内容，您可以使用变量引用工作簿和工作表等

编辑：已完成但未测试

Sub CopyPasteOAP(bookname)

    Dim wbMaster As Workbook, wsMaster As Worksheet
    Dim wbSrc As Workbook, wsSrc As Worksheet, wsNew As Worksheet
    Dim f As Range, rcopy As Range

    Set wbMaster = ThisWorkbook
    Set wsMaster = wbMaster.Sheets(1)

    Set wbSrc = Workbooks(bookname)
    Set wsSrc = wbSrc.Worksheets(1)
    Set wsNew = wbSrc.Worksheets.Add(after:=wbSrc.Worksheets(1))

    With wsSrc
        .Range(.Range("G1"), .Range("G1").End(xlDown)).Copy wsNew.Range("A1") 'Date Column
        .Range(.Range("B1"), .Range("B1").End(xlDown)).Copy wsNew.Range("B1") 'Unit Column
        .Range(.Range("H1"), .Range("H1").End(xlDown)).Copy wsNew.Range("G1") 'Severity Column
        .Range(.Range("BL1"), .Range("BL1").End(xlDown)).Copy wsNew.Range("M1") 'Fuel in Oil
        .Range(.Range("BP1"), .Range("BP1").End(xlDown)).Copy wsNew.Range("N1") 'Coolant in Oil
    End With

    wsNew.Range("C2:C50").Value = "OAP" 'Enter in OAP

    FindAndCopy wsSrc, "Lab Comments", wsNew.Range("D1") 'Fault Description = Lab Comments
    FindAndCopy wsSrc, "Lab Recommendations", wsNew.Range("L1") 'Notes = Lab Recommendations

    Set rcopy = wsNew.Range(wsNew.Range("A2"), wsNew.Range("A2").End(xlToRight))
    Set rcopy = wsNew.Range(rcopy, rcopy.End(xlDown))

    With rcopy.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With

    'copy to first empty row
    rcopy.Copy wsMaster.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)

    wbSrc.Close False


End Sub


'utliity sub: find and copy a column if it exists
Sub FindAndCopy(sht As Worksheet, hdr As String, rngDest As Range)
    Dim f As Range
    Set f = sht.Cells.Find(What:=hdr, LookIn:=xlValues, LookAt:=xlPart, _
                  SearchDirection:=xlNext, MatchCase:=False)

    If Not f Is Nothing Then
        sht.Range(f, f.End(xlDown)).Copy rngDest
    Else
        MsgBox hdr & " not found!", vbExclamation
    End If
End Sub

---

读了一会儿之后，我发现我不允许在工作簿之间使用CodeName属性。它在工作簿中工作以访问工作表，但不激活和选择VBA代码所在工作簿之外的工作表

我将探讨已经介绍过的其他选项，但这至少有助于我不再试图弄清楚在一个工作簿中有效的内容在另一个工作簿中无效。艰苦的学习——这是我不会很快忘记的一课

成功

从Tim获得优化代码，适用于将第一张工作表命名为工作簿名称的.csv情况。删除了.csv，然后用工作表“名称”引用每个文件。工作完美。为Tim提供优化提示的道具，这也允许一些速度改进

截断工作簿名称，使其与工作表（Sheet1）的名称匹配 booknamelesscsv=左侧（bookname，Len（bookname）-4）

已启动例行程序（参考命名工作表） 带wbSrc.Sheets（书名为SCSV）

将数据从命名工作表复制到新工作表“Sheet1”（Sheet2） .Range（.Range（“G1”），.Range（“G1”）.End（xlDown））。复制wbSrc.Sheets（“Sheet1”）。Range（“A1”）

现在一切正常。导入数据、制定公式、报告

---

谢谢。

您能告诉我们您正在尝试的代码吗？我如何添加代码？也许可以用一些示例文件名和数据来演示这个问题。我在那里跟了你好一阵子，但后来迷路了。关于添加代码，只需编辑您的问题并发布代码（希望还有一些数据）我如何将数据附加到电子表格中？您可能希望从阅读以下内容开始：。我不能确定，但这可能与代码中的所有

有关。选择
和
。激活
。谢谢你，蒂姆，你的代码确实优雅、高效，但我在回答中添加的问题仍然存在。Sheet2.Range（“…”）步骤在执行过程中失败，因为它们是在运行VBA代码的工作簿之外指定的工作表。这令人愤怒，因为我可以在属性页中看到工作表代码名，并且它与其他所有工作簿一样。我将试验其他工作表调用协议。CSV中的第一张图纸的优点是，它是文件“bookname”的名称，然后添加的图纸成为“Sheet1”。也许还有希望！成功！！！将“.csv”文件数据打开页（Sheet1）的页引用更改为：wbSrc.Sheets（booknamelesscsv），将编译页（Sheet2）的页引用更改为wbSrc.Sheets（“Sheet1”）.Range（“A1”）。复制并粘贴，重新格式化，然后将结果复制到主工作簿，关闭文件，然后继续复制到下一个工作簿。