Excel VBA: 循环遍历工作表 / 数据传输 / 为每个工作簿创建新的工作簿

Question

请问您能帮我调整一下我的宏吗？

我有什么

• 通过文件浏览器对话框选择不同的工作簿（wb1，wb2..），并在列表框中列出它们

• 从选定的工作簿中传输某些数据到工作簿模板（wb_template），并将其保存为新工作簿。

• 新工作簿包含来自wb_1的数据，但wb_template的结构如下：

我需要什么

我需要调整从工作簿中选择相关数据的方式（“传输数据”按钮）。 我需要一个循环，遍历每个wb_1的工作表，并涵盖以下内容：

• 在wb_1中查找特定术语，并将其移动/重命名到特定的工作表/列/单元格中的wb_template。
  例子：

• 在wb_1中查找特定术语，并仅取其右侧存储的值，并将其移动到特定工作表/列/单元格中的wb_template。
  例子：

上述步骤应适用于wb_1的每个工作表，对于每个工作表都应创建一个新工作簿。

因此，在过程结束时，我应该拥有每个wb_1工作表的一个新工作簿。
例如： 如果wb_1有5个工作表，则应创建5个新工作簿（wb1_1，wb1_2，wb1_3，...）。

以下是一个简单的概述可视化，展示了我要使用此宏实现的内容：

我的实际代码

转移数据按钮

Sub Transferfile(wbTempPath As String, wbTargetPath As String)
    Dim wb1 As Workbook
    Dim wb_template As Workbook

    Set wb1 = Workbooks.Open(wbTargetPath)
    Set wb_template = Workbooks.Open(wbTempPath)

    '/* Definition of the value range */
    wb_template.Sheets("Sheet1").Range("A2").Value = wb1.Sheets("Sheet1").Range("A2").Value
    wb_template.Sheets("Sheet1").Range("A3").Value = wb1.Sheets("Sheet1").Range("A3").Value
    wb_template.Sheets("Sheet1").Range("B2").Value = wb1.Sheets("Sheet1").Range("B2").Value
    wb_template.Sheets("Sheet1").Range("B3").Value = wb1.Sheets("Sheet1").Range("B3").Value

    wb1Name = Left(wb1.Name, InStr(wb1.Name, ".") - 1)
    wb_template.SaveAs wb1.Path & "\" & wb1Name & "_New.xlsx"
    wb1.Close False
    wb_template.Close False
End Sub

浏览文件按钮 - 我想这个话题并不相关。

Private Sub CommandButton1_Click()
    Dim fNames As Variant

    With Me
        fNames = Application.GetOpenFilename("Excel File(s) (*.xls*),*.xls*", , , , True)
        If IsArray(fNames) Then .ListBox1.List = fNames
    End With
End Sub

​
Private Sub CommandButton2_Click()
    Dim i As Integer

    '/* full path to the template file */
    Const mytemplate As String = "C:\Users\PlutoX\Desktop\Excel-Folder\wb_template.xlsx"

    With Me
        With .ListBox1
            '/* iterate listbox items */
            For i = 0 To .ListCount - 1
                '/* transfer the files using the generic procedure */
                Transferfile mytemplate, .List(i, 0)
            Next
        End With
    End With
End Sub​

感谢您的帮助！

摘要：

我需要在wb1的一个表格中搜索特定关键词。

我不知道这些关键词的位置。

如果找到关键词 - 将应用条件1或条件2，具体取决于关键词：

条件1：如果wb1中的关键词为“House_1”，则将关键词复制/粘贴到wb2中（特定位置-> Sheet2，A3），并将其重命名为“House Blue”。结果是：在wb2的Sheet2的A3中出现“House Blue”。

条件2：如果wb1中的关键词为“Number”，则将其右侧相邻单元格的值复制并粘贴到wb2中（特定位置-> Sheet3，C5）。结果是：在wb2的Sheet3的C5中出现“4”。

因此，我想要确定相关关键字 - 以及触发相应关键字的条件。

更新：

我不知道具体的工作表，因此应检查wb中的每个工作表。

实际上，我的目标是拥有一组关键词，这些关键词已分配条件1或条件2，以及在wb_template中的特定粘贴位置。因此，应根据关键词集检查每个工作表。一个关键词只能分配一个条件。

- PlutoX

---

看一下这个链接，可能会有所帮助：https://stackoverflow.com/q/30575923/4961700 - Solar Mike

你描述得很清楚你需要什么。但我不确定你到底卡在哪里了？你只是需要将你的代码包装在一个循环中，循环遍历所有的工作表吗？ - Pᴇʜ

你的问题太不具体了。只有这两个关键词（House_1，Number）和这两个条件吗？地址/位置是固定的吗？ - Pᴇʜ

嗨，看到上面的更新。只有这两个条件。但是会有一组不同的关键词。w1中的位置不固定。这些关键词粘贴到的位置是固定的 - 因此每个关键词在wb_template中都有一个固定的“粘贴到”位置。 - PlutoX

需要澄清一些问题：您如何定义关键字及其相应的定义？它们是否在某处列出？您会在代码中定义这些关键字吗？如果找到/满足关键字/条件，它们会在原始文件的每个工作表上进行搜索吗？如果找到/满足关键字/条件，目标将使用哪个范围？它是否类似于在源工作表中找到的位置？ - Zack Barresse

Answer 1

如果你面临的挑战是在工作簿中找到一个特定的单词，即使它可能散落在任何地方，你可以利用 Excel 内置的“查找”功能，并进行轻微的修改。我将发布一段示例代码，执行相同操作。请根据需要进行修改。

代码片段：[已尝试并测试过]

Sub FindMyWord()

Dim sht As Worksheet  
For Each sht In ThisWorkbook.Sheets     'Change workbook object accordingly  

Dim CellWhereWordIs As Range
Set CellWhereWordIs = sht.Cells.Find("Charlie", LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
                                    'Charlie is the word I wanna find. Change parmeters accordingly  

    If Not CellWhereWordIs Is Nothing Then
    
         'Do something here
          MsgBox "Word found in: " & sht.Name & "/" & CellWhereWordIs.Address
    
    Else
    
          MsgBox "Word not found in " & sht.Name, vbExclamation

    End If  

Next  

End Sub

- Charlie

Answer 2

我认为您只需要将代码包装成一个循环，遍历所有工作表。

我也建议使用更具描述性的变量名：wb1不是很描述清楚，但如果你把它改成wbSource，就非常清楚这是数据来源的工作簿。

最后，我建议使用Application.PathSeparator而不是"\"，使其与操作系统无关（例如，MacOS使用"/"而不是"\"）。

Option Explicit

Public Sub TransferFile(TemplateFile As String, SourceFile As String)
    Dim wbSource As Workbook
    Set wbSource = Workbooks.Open(SourceFile) 'open source

    Dim wbTemplate As Workbook
    Dim NewWbName As String

    Dim wsSource As Worksheet
    For Each wsSource In wbSource.Worksheets 'loop through all worksheets in source workbook
        Set wbTemplate = Workbooks.Open(TemplateFile) 'open new template

        '/* Definition of the value range */
        With wbTemplate.Worksheets("Sheet1")
            .Range("A2").Value = wsSource.Range("A2").Value
            .Range("A3").Value = wsSource.Range("A3").Value
            .Range("B2").Value = wsSource.Range("B2").Value
            .Range("B3").Value = wsSource.Range("B3").Value
        End With

        NewWbName = Left(wbSource.Name, InStr(wbSource.Name, ".") - 1)
        wbTemplate.SaveAs wbSource.Path & Application.PathSeparator & NewWbName & "_New.xlsx"
        wbTemplate.Close False 'close template
    Next wsSource

    wbSource.Close False 'close source
End Sub

- Pᴇʜ

---

非常感谢您的反馈！现在我有了一个遍历工作表的想法。然而，我的初始问题/疑问仍然存在——我不知道如何重新定义代码中的“值范围”……目前范围是固定的，但我需要它像“我需要”的第1和第2点所解释的那样。该代码必须在将数据传输到wb_template之前在wb_1中搜索某些关键字/术语。我不确定如何做到这一点…… - PlutoX

要查找特定关键字，请查看Range.Find方法或WorksheetFunction.VLookup方法。然后，您可以使用Range.Offset属性相对移动到找到的单元格。 - Pᴇʜ

谢谢您的建议，但我仍然不确定如何根据方法实现条件...？我已经更新了我的帖子，并添加了一个“摘要”以便更好地理解。 - PlutoX