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

我有一个默认模板，需要在源模板的列I的输出工作表的A列（材料）中填充值。 我创build了一个基于源模板中的零件数量复制输出行数的macros。 这里的问题是部件号只在第一列填充，而不能循环到其他空白行。

源模板

示例输出表

结果：

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 Windowbuild议Step Into它，那么你将能够看到/学习每行代码正在做什么，并进行必要的修正。 除此之外，为了让你的代码在所有行中循环 ，在 Process_File 过程 的结尾附近 删除这一行 。

看来您的目标是复制工作表Plant中的所有logging乘以工作表Input_sheet的Part Numbers的数量，分配给工作表中的每个logging在工作表Input_sheet分别input每个Part Numbers 。 如果这是正确的，那么试试这个代码：

解：

这段代码假设如下：

• 零件编号是连续的（中间没有空白单元格）
• 工作表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 

build议阅读以下页面，以深入了解所使用的资源：

Option关键字 ， On Error语句 ， With语句 ， 使用数组 ，

WorksheetFunction对象（Excel） ， For … Next语句 ，

Range对象（Excel） ， Range.CurrentRegion属性（Excel） ， Range.Offset属性（Excel）