Excel VBA to duplicate and fill the default template based on number of rows - excel

Question

I have a default template and need to populate the value in A column (Material) of the output sheet from column I of the source template. I created a macro which duplicates the number of output row based on number of parts in source template. The issue here is the part number is populated only in the first column and its not looping to the other blank rows.
Source Template
Sample Output sheet
Result:
VBA Code:
Sub Process_File()
Dim Src_File As Workbook
Dim Out_Template As Workbook
Dim Src_Tot_Row, Out_Tot_Row As Integer
Dim REG_CODE
REG_CODE = "C299"
Set Src_File = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Source_Data.xlsx") 'Read source file name
Set Out_Template = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Plant\AMS.xlsx") 'Read output template file name
'------------------------------------------------------------------- Portion-2
' Workbooks.Open (Sheet1.Range("G7").Value) ' Open source excel file
Src_File.Sheets("Input_sheet").Activate
If Range("I7").Value <> "Part numbers" Then ' Checking correct input file
MsgBox "Select correct source file.!"
End
End If
Range("I8").Select
Selection.End(xlDown).Select
Src_Tot_Row = ActiveCell.Row
'------------------------------------------------------------------- Portion-3
' Workbooks.Open (Sheet1.Range("G9").Value) ' Open output template excel file
Out_Template.Sheets("Plant").Activate 'Find Total Rows in Output Template
Range("B1").Select
Selection.End(xlDown).Select
Out_Tot_Row = ActiveCell.Row
Dim Temp_Row_Calc As Integer
Temp_Row_Calc = Src_Tot_Row - 7
Temp_Row_Calc = (Out_Tot_Row - 2) * Temp_Row_Calc ' Calculate total rows for data duplicate
Range("A2:AJ" & Out_Tot_Row).Copy
Range("A" & Out_Tot_Row + 1 & ":AJ" & Temp_Row_Calc + 2).PasteSpecial xlPasteValues
'------------------------------------------------------------------- Portion-4
Range("A1").EntireColumn.Insert ' Inserting temporary column for sorting back
Range("A1").Value = "1"
Range("A" & Temp_Row_Calc - 1).Select
Temp_Row_Calc = Temp_Row_Calc - 1
Range(Selection, Selection.End(xlUp)).Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=Temp_Row_Calc, Trend:=False
If ActiveSheet.AutoFilterMode = False Then ' Check Filter Mode and apply
ActiveSheet.Range("A1").AutoFilter
End If
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
"C1:C" & Temp_Row_Calc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Plant").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For I = 2 To Temp_Row_Calc
If Range("C" & I).Value = REG_CODE Then
Src_File.Sheets("Input_Sheet").Activate 'Activate Source Excel
ReDim ary(1 To Src_Tot_Row - 1) ' Copy material numbers
For j = 1 To Src_Tot_Row - 1
ary(j) = Src_File.Sheets("Input_Sheet").Cells(j + 1, 1)
Next j
Range("I8:I" & Src_Tot_Row).Copy 'Copy source part numbers
Out_Template.Sheets("Plant").Activate 'Activate Out Template Excel
Range("B" & I).SpecialCells(xlCellTypeVisible).PasteSpecial (xlPasteValues)
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
"A1:A" & Temp_Row_Calc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Plant").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'filtervalues = """8121-0837"", ""B5L47-67901"", ""B5L47-67903"", "" ="""
ary(Src_Tot_Row - 7) = ""
ActiveSheet.Range("$A$1:$AJ$" & Temp_Row_Calc).AutoFilter Field:=2, Criteria1:=ary, Operator:=xlFilterValues
Dim cl As Range, rng As Range
Set rng = Range("A2:A" & Temp_Row_Calc)
For Each cl In rng
If cl.EntireRow.Hidden = False Then 'Use Hidden property to check if filtered or not
If cl <> "" Then
x = cl
Else
cl.Value = x
End If
End If
Next
Exit For
End If
Next I
If ActiveSheet.AutoFilterMode Then ' Check Filter Mode and apply
ActiveSheet.Range("A1").AutoFilter
End If
Columns(1).EntireColumn.Delete
MsgBox "Completed!"
'-------------------------------------------------------------------
End Sub
Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
Sub Test()
Range("A1").Value = "1"
Range("A" & Out_Tot_Row).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=Out_Tot_Row, Trend:=False
End Sub

Answer 1

Your code has several errors, suggest to Step Into it using [F8] and the Locals Window then you will be able to see/learn what each line of the code is doing and apply necessary correction. Besides that, to have your code looping through all rows remove this line Exit For near the end of the Process_File procedure.
It seems that your objective is to duplicate all records in the worksheet Plant times the number of Part Numbers in worksheet Input_sheet, assigning to each record in the worksheet Plant each of the Part Numbers in worksheet Input_sheet. If this is correct then try this code:
Solution:
This code assumes the following:
The Part Numbers are continuous (no blank cells in between)
The Data in worksheet Plant is continuous, starting at A1 and contains a header row.
.
Rem The following two lines must be at the top of the VBA Module
Option Explicit
Option Base 1
Sub Process_File()
Dim wbkSrc As Workbook, wbkTrg As Workbook
Dim wshSrc As Worksheet, wshTrg As Worksheet
Dim aPrtNbr As Variant, aData As Variant
Dim lItm As Long, lRow As Long
Rem Application Settings OFF
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Rem Set Source Worksheet
On Error Resume Next
Set wbkSrc = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Source_Data.xlsx")
Set wshSrc = wbkSrc.Worksheets("Input_sheet")
If wshSrc Is Nothing Then GoTo ExitTkn
Rem Set Target Worksheet
Set wbkTrg = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Plant\AMS.xlsx")
Set wshTrg = wbkTrg.Worksheets("Plant")
If wshTrg Is Nothing Then GoTo ExitTkn
Rem Application Settings OFF
Application.DisplayAlerts = False
With wshSrc.Range("I7")
If .Value2 <> "Part numbers" Then
Rem Validate Input Worksheet
MsgBox "Select correct source file!", vbSystemModal + vbCritical
GoTo ExitTkn
Else
Rem Set Part Number Array
aPrtNbr = .Offset(1).Resize(-.Row + .End(xlDown).Row).Value2
aPrtNbr = WorksheetFunction.Transpose(aPrtNbr)
End If: End With
Rem Set Data Array
With wshTrg.Cells(1).CurrentRegion
aData = .Offset(1).Resize(-1 + .Rows.Count).Value2
End With
Rem Duplicate Data and Assign Part Numbers
With wshTrg
For lItm = 1 To UBound(aPrtNbr)
lRow = lRow + IIf(lItm = 1, 2, UBound(aData))
With .Cells(lRow, 1).Resize(UBound(aData), UBound(aData, 2))
.Value = aData
.Columns(1).Value = aPrtNbr(lItm)
End With: Next: End With
ExitTkn:
Rem Application Settings OFF
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Option keyword,
On Error Statement,
With Statement,
Using Arrays,
WorksheetFunction Object (Excel),
For...Next Statement,
Range Object (Excel),
Range.CurrentRegion Property (Excel),
Range.Offset Property (Excel)