Excel VBA根据行数复制和填充默认模板

Question

我有一个默认模板，需要从源模板的 I 列填充输出表的 A 列（材料）中的值。我创建了一个宏，它根据源模板中的部件数复制输出行数。这里的问题是零件编号仅填充在第一列中，并且没有循环到其他空白行。

源模板

样本输出表

结果：

VBA 代码：

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

您的代码有几个错误，建议使用 [F8] 和 Locals Window 向Step Into 发送代码，然后您将能够查看/了解代码的每一行正在执行的操作并进行必要的更正。 除此之外，要让您的代码循环遍历所有行，请删除此行 Exit For 接近结尾 Process_File 过程。 p>

您的目标似乎是复制工作表Plant 中的所有记录乘以工作表Input_sheet 中Part Numbers 的数量，分配给工作表Plant 中的每条记录@ 工作表中的每个Part Numbers Input_sheet。如果这是正确的，那么试试这个代码：

解决方案：

此代码假设如下：

• 部件号是连续的（中间没有空白单元格）
• 工作表Plant 中的数据是连续的，从A1 开始并包含一个标题行。

.

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

建议阅读以下页面以更深入地了解所使用的资源：

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)