Excel VBA: Loop through sheets / transfer data / create new workbook for each

Question

could you please help me out adjusting my macro?

What I have

• Selecting different workbooks(wb1,wb2...) via a file explorer dialog window and listing them in a listbox

• Transfering certain data from the selected workbooks to a workbook template(wb_template) and saving it as a new workbook.

• The new workbook contains the data from wb_1, but the structure of wb_template The User Form Looks like this:

What I need

I need to adjust the way the relevant data from the workbooks is selected("Transfer-data" button). I would need a loop which is going through every sheet of wb_1 and is covering the following:

• Look for certain terms in wb_1 and move/rename them to wb_template in specific sheet/column/cell.
  Example:

• Look for certain terms in wb_1 and just take the value, which is stored in the cell on the right side of it, and move to wb_template in specific sheet/column/cell.
  Example:

The steps above should be applied to every sheet of wb_1 and for every sheet should be a new workbook created.

So, at the end of the process I should have a new workbook for every sheet in wb_1.
For example: if wb_1 has 5 sheets, there should be 5 new workbooks created (wb1_1, wb1_2, wb1_3,...).

​ Here is a simple overview visual showing what I exactly want to achieve with this macro:

My actual code

Transfer Data Button

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

Browse File Button - I guess not so relevant for this topic

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​

Thanks for the help!

Summary:

I need to search for for specific keywords in a sheet of wb1.

I dont know the positions of those keywords

In case a keyword is found - condition1 or condition2 will be applied, depending on the keyword:

• Condition 1: if keyword in wb1 = "House_1" then copy/paste keyword in wb2 (specific position -> Sheet2, A3) and rename it to "House Blue".Result would be: "House Blue" in A3 of Sheet2 in wb2.

• Condition 2: if keyword in wb1 = "Number" then copy the value of the adjoining cell to the right of it and paste in wb2 (specific position -> Sheet3, C5).Result would be: "4" in C5 of Sheet3 in wb2.

So what I want to do is to determine the relevant keywords - and which condition the respective keyword is triggering.

Update:

I dont know the specific sheet, so every sheet in the wb should be checked

Actually, my goal is to have a set of keywords, which have condition 1 or condition 2 assigned, as well as a specific paste-location in wb_template. So, every sheet should be checked according to the set of keywords. A keyword can only have one of the conditions assigned.

Answer 1

If the challenge you are facing is to find a specific word which could be lying anywhere in the workbook you can make use of Excel's inbuilt function "Find" with slight modification.

I will post a sample snippet which does the same. Please modify it accordingly.

Code Snippet: [ Tried & tested ]

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

I think you just need to wrap your code into a loop going through all the worksheets.

I also recommend to use a bit more descriptive variable names: wb1 is not very descriptive but if you change it to wbSource it is very clear that this is the workbook where the data comes from.

Finally I recommend to use Application.PathSeparator instead of "\" to make it independent form your operating system (eg. MacOS uses "/" instead of "\").

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