使用 VBA 代码自动填充

### 如何使用 VBA 实现单元格或表格的自动填充功能 VBA（Visual Basic for Applications）是一种强大的工具，可以用于实现 Excel 中的自动化任务。以下是一个详细的说明，介绍如何通过 VBA 实现单元格或表格的自动填充功能。 #### 1. 基于特定列触发的自动填充 当用户在某一列输入数据时，可以通过事件监听器 `Worksheet_Change` 实现自动填充其他列的功能。例如，如果用户在 A 列输入内容，则可以在后面的列中填充相关信息[^1]。 ```vba Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> [A1].Column Then Exit Sub ' 检查目标单元格是否在 A 列 If Target.Count > 1 Then Exit Sub ' 如果选中多个单元格，则退出 If Target = "" Then Target.Offset(0, 5).Resize(1, 3) = "" ' 清除目标单元格右边第 5 个单元格之后的 3 个单元格的内容 Exit Sub End If Set xrng = Sheets("说明").Range("A:A").Find(Target) ' 在“说明”工作表中查找与目标单元格匹配的内容 If Not xrng Is Nothing Then Target.Offset(0, 5).Resize(1, 2) = xrng.Offset(0, 1).Resize(1, 2).Value ' 自动填充目标单元格右边第 5 个单元格之后的 2 个单元格 End If End Sub ``` #### 2. 根据条件动态改变单元格颜色 除了自动填充内容，还可以根据某些条件动态改变单元格的颜色。以下代码展示了如何根据单元格是否有边框来决定其背景色[^2]。 ```vba Private Sub Worksheet_Change(ByVal Target As Range) For i = 1 To 100 Dim a As String a = "B" + CStr(i) If Range(a).Borders.LineStyle = xlNone Then Exit For ' 如果当前行的第二个单元格没有边框，则退出循环 For j = 2 To 20 If i Mod 2 = 1 Then Cells(i, j).Interior.Color = RGB(82, 191, 197) ' 奇数行填充为浅绿色 Else Cells(i, j).Interior.Color = RGB(139, 190, 221) ' 偶数行填充为浅蓝色 End If Next Next End Sub ``` #### 3. 根据单元格颜色填充其他单元格 如果需要根据源单元格的颜色来填充目标单元格的颜色，可以使用以下代码[^3]： ```vba Sub FillColorBasedOnSource() Dim sourceCell As Range Dim targetCell As Range Set sourceCell = Range("D4") ' 源单元格 Set targetCell = Range("E4") ' 目标单元格 With targetCell.Interior .Pattern = xlPatternSolid .ThemeColor = sourceCell.Interior.ThemeColor .TintAndShade = sourceCell.Interior.TintAndShade .PatternColorIndex = sourceCell.Interior.PatternColorIndex End With End Sub ``` #### 4. 将二维数组写入单元格区域 有时需要将一个二维数组的数据一次性写入到 Excel 的某个区域。以下代码展示了一个函数，用于将二维数组的内容输出到指定的单元格区域[^4]。 ```vba Function ArrToRange(arr, rng As Range) ' 将二维数组 arr 输出到以 rng 为左上角的单元格区域 rng.Resize(UBound(arr) - LBound(arr) + 1, UBound(arr, 2) - LBound(arr, 2) + 1) = arr End Function ``` #### 5. 批量新建工作簿并自动填充信息 如果需要根据模板批量生成新的 Excel 工作簿，并在每个新工作簿中自动填充相关信息，可以参考以下代码[^5]。此代码分为两部分：一部分用于复制模板，另一部分用于填充数据。 ```vba Sub CreateWorkbooksFromTemplate() Dim wsSource As Worksheet Dim wsTemplate As Worksheet Dim newWb As Workbook Dim cell As Range Set wsSource = ThisWorkbook.Sheets("名单") ' 包含名单的工作表 Set wsTemplate = ThisWorkbook.Sheets("模板") ' 模板工作表 Application.ScreenUpdating = False For Each cell In wsSource.Range("A2:A" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row) If cell.Value <> "" Then wsTemplate.Copy Set newWb = ActiveWorkbook newWb.Sheets(1).Range("B1").Value = cell.Value ' 填充相关信息 newWb.SaveAs Filename:="C:\Temp\" & cell.Value & ".xlsx" ' 保存到指定路径 newWb.Close End If Next cell Application.ScreenUpdating = True End Sub ``` ---