VBA表格数据导出代码优化咨询：现有代码能否简化？

Great job getting the code up and running as a VBA beginner! The biggest opportunity to clean this up is eliminating the repetitive code blocks for each table—since Tabel1-Tabel4 all follow the exact same pattern, we can wrap that logic into a reusable flow and loop through each table instead of writing duplicate code. Let’s break down the simplifications and share the optimized version:

Key Optimizations We’ll Make #

• Extract Reusable Logic: Replace 4 nearly identical code blocks with a single loop that handles all tables.
• Avoid ActiveSheet/ActiveWorkbook: Explicitly reference worksheets/workbooks to prevent unexpected errors if the user clicks another sheet mid-run.
• Simplify FillDown: Use the table’s own row count to define the fill range (no need for repeated Find calls).
• Reduce Clutter: Cache fixed values (like C3, C4, C6) once instead of reading them 4 times, and remove redundant variables.
• Early Exit: Short-circuit the code immediately if the password is wrong or the H2 check fails, making the flow cleaner.

Optimized Code #

Private Sub CommandButton5_Click()
    Dim PassWord As Variant
    PassWord = InputBox("Wachtwoord?")
    
    ' Exit early if password is incorrect
    If PassWord <> "Something" Then Exit Sub
    
    ' Check if H2 is non-zero before proceeding
    If Sheets("Variabelen").Range("H2") <> 0 Then
        MsgBox ("Niet nog een keer Sylvia!!!!")
        Exit Sub
    End If
    
    ' Define core objects upfront to avoid relying on Active*
    Dim sourceWB As Workbook
    Dim sourceSheet As Worksheet
    Dim targetWB As Workbook
    Dim targetSheet As Worksheet
    Dim fixedVals(1 To 3) As Variant ' Store C3, C4, C6 values once
    
    Set sourceWB = ActiveWorkbook
    Set sourceSheet = sourceWB.Sheets(1)
    Set targetWB = Workbooks.Open("\\Somewhere\Test_Masterbestand Afdeling.xlsx")
    Set targetSheet = targetWB.Worksheets("Data")
    
    ' Cache fixed values from source sheet to avoid repeated range calls
    fixedVals(1) = sourceSheet.Range("C3").Value
    fixedVals(2) = sourceSheet.Range("C4").Value
    fixedVals(3) = sourceSheet.Range("C6").Value
    
    ' Array to map each table name to its category label
    Dim tablePairs As Variant
    tablePairs = Array( _
        Array("Tabel1", "Huidige medewerker in opleiding"), _
        Array("Tabel2", "Nieuwe instroom in opleiding"), _
        Array("Tabel3", "Afdelingspecifiek"), _
        Array("Tabel4", "Individueel") _
    )
    
    Dim i As Integer
    Dim currentTable As ListObject
    Dim tableData As Range
    Dim targetStartRow As Long
    Dim tableRowCount As Integer
    
    ' Loop through each table and its category
    For i = LBound(tablePairs) To UBound(tablePairs)
        Set currentTable = sourceSheet.ListObjects(tablePairs(i)(0))
        Set tableData = currentTable.DataBodyRange
        
        ' Skip tables with no data to avoid errors
        If tableData Is Nothing Then
            MsgBox tablePairs(i)(0) & " heeft geen gegevens om te kopiëren!"
            GoTo NextTable
        End If
        
        tableRowCount = tableData.Rows.Count
        targetStartRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row + 1
        
        ' Copy table values to target sheet
        tableData.Copy
        targetSheet.Range("A" & targetStartRow).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        ' Set fixed column values (I-L) and fill down if needed
        With targetSheet
            .Range("I" & targetStartRow).Value = tablePairs(i)(1)
            .Range("J" & targetStartRow).Value = fixedVals(1)
            .Range("K" & targetStartRow).Value = fixedVals(2)
            .Range("L" & targetStartRow).Value = fixedVals(3)
            
            ' Fill down columns if table has more than 1 row
            If tableRowCount > 1 Then
                .Range("I" & targetStartRow & ":I" & targetStartRow + tableRowCount - 1).FillDown
                .Range("J" & targetStartRow & ":J" & targetStartRow + tableRowCount - 1).FillDown
                .Range("K" & targetStartRow & ":K" & targetStartRow + tableRowCount - 1).FillDown
                .Range("L" & targetStartRow & ":L" & targetStartRow + tableRowCount - 1).FillDown
                
                ' Handle column N fill specifically for Tabel4
                If tablePairs(i)(0) = "Tabel4" Then
                    Dim lastRowN As Long
                    lastRowN = .Range("N:N").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    .Range("N" & lastRowN & ":N" & targetStartRow + tableRowCount - 1).FillDown
                End If
            End If
        End With
        
NextTable:
    Next i
    
    ' Uncomment these lines when ready for production
    ' targetWB.Close SaveChanges:=True
    ' Sheets("Variabelen").Range("H2").Value = Sheets("Variabelen").Range("H2").Value + 1
    
    MsgBox "Gegevens succesvol gekopieerd!"
End Sub

Breakdown of Changes #

1. Early Exit Logic: We check for invalid passwords or non-zero H2 first, exiting immediately instead of nesting all code inside If blocks—this makes the code easier to read.
2. Explicit Object References: By defining sourceWB, sourceSheet, etc., we never rely on ActiveSheet, which prevents bugs if the user switches sheets while the code runs.
3. Loop Through Tables: Using an array to map table names to their category labels lets us run the same copy/fill logic for all 4 tables, cutting down on hundreds of lines of duplicate code.
4. Cached Fixed Values: We read C3, C4, and C6 once and store them in an array, which is a small performance boost and keeps the code cleaner.
5. Simplified Fill Range: Instead of searching for the last row with Find, we calculate the fill range using the table’s row count (targetStartRow + tableRowCount - 1)—this is more reliable because we know exactly how many rows we copied.
6. Empty Table Check: We added a check to skip tables with no data, preventing runtime errors if a table is empty.

内容的提问来源于stack exchange，提问作者Wilco van der Helm