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 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中搜索特定的关键字。

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

如果找到了关键字-根据关键字，将应用condition1或condition2：

条件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中的每个工作表

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

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

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

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

我有什么

我需要什么

我的实际代码

2 个答案: