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创建每张纸.

因此,在流程结束时,我应该new workbook为每张纸都有一个wb_1.
例如:如果wb_1有5张,则应该有5个new workbookscreated(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中搜索特定的关键字.

我不知道这些关键字的位置

如果找到关键字,将应用condition1或condition2,具体取决于关键字:

• 条件1:如果wb1 ="House_1"中的关键字然后在wb2中复制/粘贴关键字(特定位置 - > Sheet2,A3)并将其重命名为"House Blue".结果将是:Wb2中Sheet2的A3中的"House Blue" .

• 条件2:如果wb1 ="Number"中的关键字然后将相邻单元格的值复制到它的右边并粘贴到wb2(特定位置 - > Sheet3,C5).结果将是:在Sheet3的C5中为"4" WB2.

所以我想要做的是确定相关的关键字 - 以及相应的关键字触发的条件.

更新:

我不知道具体的纸张,所以应该检查wb中的每张纸

实际上,我的目标是拥有一组关键字,分配条件1或条件2,以及wb_template中的特定粘贴位置.因此,应根据关键字集检查每张工作表.关键字只能分配其中一个条件.

Answer 1

我认为您只需将代码包装到遍历所有工作表的循环中即可。

我还建议使用更具描述性的变量名称：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