Excel VBA：循环工作表/传输数据/为每个工作表创建新工作簿

Question

你能帮我调整一下我的宏吗？

我有什么

• 通过文件资源管理器对话框选择不同的工作簿 (wb1,wb2...) 窗口并在列表框中列出它们

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

• new workbook 包含来自wb_1 的数据，但结构为 wb_template 用户表单如下所示：

我需要什么

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

• 在wb_1 中查找某些术语，然后在特定工作表/列/单元格中将它们移动/重命名为wb_template。
  示例：

• 在wb_1 中查找某些术语，然后取出存储在其右侧单元格中的值，然后移动到特定工作表/列/单元格中的wb_template。
  示例：

上述步骤应应用于wb_1 的每张工作表，并且应为每张工作表创建一个new workbook。

因此，在流程结束时我应该为wb_1 中的每个工作表设置一个new workbook。
例如：如果wb_1有 5 张，应该有 5 个 new workbooks 创建 (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）并将其重命名为 “房子蓝色”。结果将是：wb2 中 Sheet2 的 A3 中的“房子蓝色”。

• 条件二：如果 wb1 中的关键字 = "Number" 则将相邻单元格的值复制到其右侧并粘贴到 wb2 中（具体 position -> Sheet3, C5).Result 将是：wb2 中 Sheet3 的 C5 中的“4”。

所以我要做的是确定相关的关键字——以及各个关键字触发的条件。

更新：

我不知道具体的工作表，所以应该检查 wb 中的每个工作表

实际上，我的目标是拥有一组关键字，它们分配了条件 1 或条件 2，以及 wb_template 中的特定粘贴位置。因此，应根据关键字集检查每张纸。一个关键字只能指定一个条件。

Answer 1

如果您面临的挑战是找到一个特定的单词它可能位于工作簿中的任何位置，您可以利用 Excel 的内置功能 “查找" 稍作修改。

我将发布一个相同的示例 sn-p。请相应修改。

代码片段：[尝试和测试]

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

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