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

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