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

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

EEM EEM · Accepted Answer · 2017-01-05T19:44:15

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)

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

1 Answers