VBACODE.AI Example Gallery
Every code snippet below was generated live by VBACODE.AI without manual edits — showing real output quality across generate, fix, and explain modes.
Multi-file Consolidation
Prompt
Loop through all .xlsx files in D:\Reports, copy A/B/C columns from each file's Sheet1 into the Summary sheet of the current workbook, and append the source filename to each row.
Option Explicit
Sub ConsolidateExcelFiles()
' 定义常量以便于后续修改配置
Const FOLDER_PATH As String = "D:\Reports\"
Const FILE_EXT As String = "*.xlsx"
Const SOURCE_SHEET_NAME As String = "Sheet1"
Const TARGET_SHEET_NAME As String = "Summary"
If MsgBox("即将从 " & FOLDER_PATH & " 汇总所有 " & FILE_EXT & " 文件。" & vbCrLf & _
"是否继续？", vbYesNo + vbQuestion, "操作确认") = vbNo Then Exit Sub
If Dir(FOLDER_PATH, vbDirectory) = "" Then
MsgBox "指定的文件夹不存在: " & FOLDER_PATH, vbExclamation, "路径错误"
Exit Sub
End If
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Set wbTarget = ThisWorkbook
On Error Resume Next
Set wsTarget = wbTarget.Worksheets(TARGET_SHEET_NAME)
On Error GoTo ErrHandler
If wsTarget Is Nothing Then
Set wsTarget = wbTarget.Worksheets.Add(Before:=wbTarget.Worksheets(1))
wsTarget.Name = TARGET_SHEET_NAME
wsTarget.Range("A1:D1").Value = Array("列A数据", "列B数据", "列C数据", "来源文件名")
End If
Dim targetNextRow As Long
targetNextRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
Dim fileName As String
fileName = Dir(FOLDER_PATH & FILE_EXT)
If fileName = "" Then
MsgBox "在指定文件夹中未找到任何 Excel 文件！", vbInformation, "提示"
GoTo Cleanup
End If
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim arrData As Variant
Dim arrOutput As Variant
Dim rowIdx As Long
Dim fileCount As Long
Do While fileName <> ""
Set wbSource = Workbooks.Open(Filename:=FOLDER_PATH & fileName, ReadOnly:=True)
Set wsSource = Nothing
On Error Resume Next
Set wsSource = wbSource.Worksheets(SOURCE_SHEET_NAME)
On Error GoTo ErrHandler
If Not wsSource Is Nothing Then
Dim sourceLastRow As Long
sourceLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
If sourceLastRow >= 1 And Not IsEmpty(wsSource.Range("A1")) Then
arrData = wsSource.Range("A1:C" & sourceLastRow).Value
If IsArray(arrData) Then
ReDim arrOutput(1 To UBound(arrData, 1), 1 To 4)
For rowIdx = 1 To UBound(arrData, 1)
arrOutput(rowIdx, 1) = arrData(rowIdx, 1)
arrOutput(rowIdx, 2) = arrData(rowIdx, 2)
arrOutput(rowIdx, 3) = arrData(rowIdx, 3)
arrOutput(rowIdx, 4) = fileName
Next rowIdx
wsTarget.Range(wsTarget.Cells(targetNextRow, 1), _
wsTarget.Cells(targetNextRow + UBound(arrOutput, 1) - 1, 4)).Value = arrOutput
targetNextRow = targetNextRow + UBound(arrOutput, 1)
fileCount = fileCount + 1
End If
End If
End If
wbSource.Close SaveChanges:=False
fileName = Dir
Loop
MsgBox "数据汇总完成！共成功处理了 " & fileCount & " 个文件。", vbInformation, "处理成功"
Cleanup:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrHandler:
MsgBox "运行过程中发生错误：" & vbCrLf & "错误代码: " & Err.Number & _
vbCrLf & "错误描述: " & Err.Description, vbCritical, "程序异常"
If Not wbSource Is Nothing Then
On Error Resume Next
wbSource.Close SaveChanges:=False
End If
Resume Cleanup
End SubLoops through all Excel files in a folder, batch-reads three columns via memory arrays, appends the filename, and writes everything to the Summary sheet in one shot. Includes full error handling, confirmation dialog, and performance optimizations.
Bulk Outlook Emails
Prompt
Read the current sheet — col A = name, col B = email, col C = amount — and send each person a personalized Outlook email with subject 'Payroll Notification' containing their name and amount.
Option Explicit
Sub SendPayrollEmails()
Const COL_NAME As Long = 1
Const COL_EMAIL As Long = 2
Const COL_AMOUNT As Long = 3
Const START_ROW As Long = 2
Const EMAIL_SUBJECT As String = "工资单通知"
Dim ws As Worksheet
Dim lastRow As Long
Dim dataArray As Variant
Dim i As Long
Dim outApp As Object
Dim outMail As Object
Dim successCount As Long
If MsgBox("是否确认向当前表格中的所有员工发送工资单邮件？", _
vbYesNo + vbQuestion, "发送确认") = vbNo Then Exit Sub
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, COL_NAME).End(xlUp).Row
If lastRow < START_ROW Then
MsgBox "未找到有效数据。", vbExclamation, "提示"
GoTo Cleanup
End If
' 一次性读入内存数组，避免逐单元格读取
dataArray = ws.Range(ws.Cells(START_ROW, 1), ws.Cells(lastRow, 3)).Value
' 使用后期绑定 (Late Binding) 获取 Outlook 实例
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then Set outApp = CreateObject("Outlook.Application")
On Error GoTo ErrHandler
If outApp Is Nothing Then
MsgBox "无法启动 Outlook，请检查是否已安装并配置 Outlook。", vbCritical, "错误"
GoTo Cleanup
End If
For i = 1 To UBound(dataArray, 1)
Dim recipientEmail As String
recipientEmail = Trim(CStr(dataArray(i, COL_EMAIL)))
If recipientEmail <> "" And InStr(recipientEmail, "@") > 0 Then
Set outMail = outApp.CreateItem(0) ' olMailItem
With outMail
.To = recipientEmail
.Subject = EMAIL_SUBJECT
.Body = "尊敬的 " & Trim(CStr(dataArray(i, COL_NAME))) & "：" & vbCrLf & _
vbCrLf & "您的本期应发金额为：" & dataArray(i, COL_AMOUNT) & " 元。" & _
vbCrLf & vbCrLf & "请注意查收。如有疑问，请联系财务部。"
.Send
End With
Set outMail = Nothing
successCount = successCount + 1
End If
Next i
MsgBox "操作完成！共成功发送 " & successCount & " 封邮件。", vbInformation, "发送成功"
Cleanup:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Set outMail = Nothing
Set outApp = Nothing
Exit Sub
ErrHandler:
MsgBox "发送过程中发生错误: " & Err.Description & " (错误代码: " & Err.Number & ")", _
vbCritical, "错误"
Resume Cleanup
End SubUses Late Binding to call Outlook, reads Excel data into a memory array, and sends personalized payroll emails in bulk. Late Binding ensures the macro runs on any machine without needing additional references.
Bulk Word Contract Generation
Prompt
Read contract data from the current Excel sheet (columns: contract number, party name, amount, date) and use a Word template to batch-generate individual contracts by replacing {合同编号}{甲方}{金额}{日期} placeholders.
Option Explicit
Sub GenerateWordContracts()
Const TEMPLATE_PATH As String = "C:\Templates\contract.docx"
Const OUTPUT_FOLDER As String = "C:\Output\"
Const COL_CONTRACT As Long = 1
Const COL_PARTY_A As Long = 2
Const COL_AMOUNT As Long = 3
Const COL_DATE As Long = 4
Const START_ROW As Long = 2
Const WD_REPLACE_ALL As Long = 2
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
' 验证模板文件存在
If Dir(TEMPLATE_PATH) = "" Then
MsgBox "找不到模板文件: " & TEMPLATE_PATH, vbCritical, "模板缺失"
GoTo Cleanup
End If
Dim ws As Worksheet
Dim lastRow As Long
Dim dataArray As Variant
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, COL_CONTRACT).End(xlUp).Row
If lastRow < START_ROW Then
MsgBox "未找到有效数据。", vbExclamation, "提示"
GoTo Cleanup
End If
dataArray = ws.Range(ws.Cells(START_ROW, 1), ws.Cells(lastRow, 4)).Value
' 后期绑定 Word 应用程序
Dim wordApp As Object
Dim wordDoc As Object
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = False
Dim successCount As Long
Dim rowIndex As Long
For rowIndex = 1 To UBound(dataArray, 1)
Dim contractNo As String
Dim partyA As String
Dim amount As String
Dim contractDate As String
contractNo = Trim(CStr(dataArray(rowIndex, COL_CONTRACT)))
partyA = Trim(CStr(dataArray(rowIndex, COL_PARTY_A)))
amount = Trim(CStr(dataArray(rowIndex, COL_AMOUNT)))
contractDate = Trim(CStr(dataArray(rowIndex, COL_DATE)))
If contractNo = "" Then GoTo NextRow
' 打开模板（每次从模板重新打开，保证占位符完整）
Set wordDoc = wordApp.Documents.Open(TEMPLATE_PATH, ReadOnly:=True)
' 替换四个占位符
Dim oFind As Object
Set oFind = wordDoc.Content.Find
With oFind
.ClearFormatting
.Replacement.ClearFormatting
.MatchCase = True
.Execute FindText:="{合同编号}", ReplaceWith:=contractNo, Replace:=WD_REPLACE_ALL
.Execute FindText:="{甲方}", ReplaceWith:=partyA, Replace:=WD_REPLACE_ALL
.Execute FindText:="{金额}", ReplaceWith:=amount, Replace:=WD_REPLACE_ALL
.Execute FindText:="{日期}", ReplaceWith:=contractDate, Replace:=WD_REPLACE_ALL
End With
Dim savePath As String
savePath = OUTPUT_FOLDER & contractNo & "_合同.docx"
wordDoc.SaveAs2 savePath
wordDoc.Close SaveChanges:=False
Set wordDoc = Nothing
successCount = successCount + 1
NextRow:
Next rowIndex
wordApp.Quit
Set wordApp = Nothing
MsgBox "合同生成完成！共生成 " & successCount & " 份合同，保存在：" & OUTPUT_FOLDER, _
vbInformation, "完成"
Cleanup:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "发生错误：" & Err.Description & " (错误代码: " & Err.Number & ")", vbCritical, "错误"
If Not wordDoc Is Nothing Then wordDoc.Close SaveChanges:=False
If Not wordApp Is Nothing Then wordApp.Quit
Resume Cleanup
End SubUses Late Binding to open Word, reads Excel data into arrays, replaces placeholders in the template for each row, and saves each result as a separate contract file.
Fix .Select Crash
Prompt
After switching sheets the macro crashes with 'Object doesn't support this property or method'.
Sub CopyData()
Sheets("数据源").Select
Range("A1:D100").Select
Selection.Copy
Sheets("汇总").Select
Range("A1").Select
ActiveSheet.Paste
Range("E1:E100").Select
Selection.Font.Bold = True
Selection.Interior.Color = RGB(255, 255, 0)
End SubEliminated all .Select and ActiveSheet calls, using direct object references instead. The code is cleaner and runs reliably regardless of which sheet has focus.
Fix Slow Loop (50k Rows)
Prompt
The sheet has 50,000 rows and the macro nearly freezes Excel. Needs a major speedup.
Sub CalcCommission()
Dim i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
For i = 2 To 50000
Dim sales As Double
sales = ws.Cells(i, 2).Value
Dim region As String
region = ws.Cells(i, 3).Value
Dim rate As Double
If region = "华东" Then
rate = 0.1
ElseIf region = "华北" Then
rate = 0.08
Else
rate = 0.06
End If
ws.Cells(i, 4).Value = sales * rate
If sales > 100000 Then
ws.Cells(i, 5).Value = "达标"
Else
ws.Cells(i, 5).Value = "未达标"
End If
Next i
End SubReplaced cell-by-cell loops with memory arrays: reads all 50k rows at once, processes in memory, then writes back in two bulk operations. Execution time drops from 10+ minutes to under 1 second.
Explain Financial Summary Macro
Prompt
Explain the MonthlyFinancialSummary macro that uses a Scripting.Dictionary to aggregate department totals.
Summary
This macro summarizes financial data by calculating the total amount per department
from a "RawData" sheet and writing the results to a "Summary" sheet. It reads source
data into a memory array and uses a Scripting.Dictionary to aggregate totals
efficiently before outputting the final report.
Line-by-Line
— Disables screen refreshes and formula recalculation to significantly speed up execution.
— Late-binds a Dictionary object, ideal for storing unique keys (departments)
and accumulating their values (totals) without duplicates.
— References the source sheet directly and finds the last used row dynamically,
so the macro works regardless of how many rows of data there are.
— Reads the entire data range into a 2D array in one shot — much faster than
reading cell by cell in a loop.
— Loops through the in-memory array. For each row, it reads the department name
and amount, then either adds a new Dictionary entry or accumulates the running total.
Suggestions
a memory array write-back rather than cell-by-cell writes for consistency.
to restore `ScreenUpdating` and `Calculation` even if an error occurs mid-run.
The AI explained how this financial summary macro uses a Scripting.Dictionary for efficient aggregation and memory arrays for fast reads, while flagging missing Option Explicit and error handling.
Find Bugs in Code
Prompt
Sub DeleteBlankRows() On Error Resume Next Dim i As Integer For i = 1 To 10000 If Cells(i, 1).Value = "" Then Rows(i).Delete End If Next i MsgBox "Done" End Sub
Summary
This macro iterates through the first 10,000 rows of the active worksheet and deletes
any row where column A is blank, then shows a "Done" message. However, it contains a
critical logical flaw that will silently skip consecutive blank rows, leaving them
undeleted.
Line-by-Line
it will hide any real problems that occur, making debugging very difficult.
if the sheet has more than 32,767 rows. Should be Long.
deleted, all subsequent rows shift up by one. The next iteration increments `i`,
so the row that just moved into position `i` is never checked. This means consecutive
blank rows will be skipped.
it always targets the currently active sheet, which may not be the intended one.
Suggestions
so that deleting a row doesn't affect the indices of rows yet to be checked.
to avoid accidental targeting of the wrong sheet.
The AI found three bugs: the classic forward-delete-skip trap, Integer overflow risk, and On Error Resume Next masking errors — and suggested looping backwards as the fix.
Explain English Code
Prompt
Sub AutoBackup() Dim sourcePath As String Dim backupPath As String Dim timestamp As String sourcePath = ThisWorkbook.FullName timestamp = Format(Now(), "YYYYMMDD_HHMMSS") backupPath = ThisWorkbook.Path & "\Backup_" & timestamp & ".xlsx" On Error GoTo ErrHandler Application.DisplayAlerts = False ThisWorkbook.SaveCopyAs backupPath Application.DisplayAlerts = True MsgBox "Backup saved to: " & backupPath, vbInformation Exit Sub ErrHandler: MsgBox "Backup failed: " & Err.Description, vbCritical End Sub
Summary
This macro creates a timestamped backup copy of the currently open workbook in the same
folder as the original. It appends the current date and time to the backup filename to
prevent overwriting previous backups. A popup confirms success or reports an error.
Line-by-Line
"20240315_143022" from the current date and time, guaranteeing a unique filename on every run.
Builds the full save path, placing the backup in the same directory as the original file.
dialog. Since we use a unique timestamp, overwriting should never happen, but this is
a safety measure to prevent the macro from hanging waiting for user input.
currently open file's name or saved state. The original file is unaffected.
and shows a descriptive error message.
Suggestions
setting if an error occurs before it is re-enabled.
whether the macro succeeds or fails.
The AI explained the timestamped backup logic and flagged an unused variable plus a risk that DisplayAlerts stays False if an error occurs before it's reset.
Decode Legacy Code
Prompt
Explain what this legacy macro with cryptic variable names (x, y, z, a, b) actually does.
Summary
这段宏代码从第2行开始遍历工作表数据，逐行比较 C 列（实际值）和 D 列（目标值），计算差额并在 E 列写入差值、F 列写入状态标签（"超出"/"持平"/"不足"），最后在数据末尾汇总所有差值的累计总和。
Line-by-Line
Suggestions
The AI decoded cryptic single-letter variables to reveal the comparison logic, found a hidden bug where z isn't reset to 0 on 'equal' rows, and provided renaming recommendations.
Explain Access DB Query
Prompt
Explain this macro that queries an Access database via ADODB and writes results to Excel.
总结
这段宏通过 ADODB 连接本地 Access 数据库 (`sales.accdb`)，执行 SQL 查询获取 2024 年以来各客户的销售额汇总（降序），将查询结果的字段名和数据写入 "QueryResult" 工作表，最后弹窗提示查询完成及记录条数。
逐行解释
Suggestions
The AI explained ADODB connection setup, ACE OLEDB driver requirements, Access date syntax using #...#, and recommended batch array writes for better performance.
Auto-Create Pivot Table
Prompt
Auto-create a pivot table from Sheet1 data with 'Department' as rows, 'Month' as columns, and 'Sales' as sum values. Place it in a new PivotReport sheet with proper formatting.
Option Explicit
Sub CreatePivotTableReport()
Const SOURCE_SHEET_NAME As String = "Sheet1"
Const DEST_SHEET_NAME As String = "PivotReport"
Const ROW_FIELD As String = "部门"
Const COL_FIELD As String = "月份"
Const DATA_FIELD As String = "销售额"
Const PIVOT_TABLE_NAME As String = "SalesPivotTable"
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets(SOURCE_SHEET_NAME)
' 获取数据范围
Dim lastRow As Long
Dim lastCol As Long
lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
Dim dataRange As Range
Set dataRange = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol))
' 若目标 Sheet 已存在则删除重建
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.Name = DEST_SHEET_NAME Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Exit For
End If
Next ws
Set wsDest = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
wsDest.Name = DEST_SHEET_NAME
' 创建透视缓存和透视表
Dim pc As PivotCache
Set pc = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)
Dim pt As PivotTable
Set pt = pc.CreatePivotTable(TableDestination:=wsDest.Range("A3"), _
TableName:=PIVOT_TABLE_NAME)
' 添加字段
With pt
.PivotFields(ROW_FIELD).Orientation = xlRowField
.PivotFields(COL_FIELD).Orientation = xlColumnField
With .PivotFields(DATA_FIELD)
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0.00"
.Name = "销售额合计"
End With
' 应用专业样式
.TableStyle2 = "PivotStyleMedium9"
.ShowGrandTotals = True
End With
wsDest.Columns.AutoFit
MsgBox "数据透视表已创建完成！", vbInformation, "完成"
Cleanup:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrHandler:
MsgBox "发生错误：" & Err.Description & " (错误代码: " & Err.Number & ")", vbCritical, "错误"
Resume Cleanup
End SubAutomatically reads the data range from Sheet1, creates a PivotReport sheet, builds a pivot table with Department rows, Month columns, and summed Sales values, then applies professional styling.
UserForm Data Entry UI
Prompt
Create a UserForm with employee name (TextBox), department dropdown (ComboBox: Sales/Tech/Finance/HR), hire date (TextBox with format validation), a Submit button (write to Sheet1), and a Clear button.
Option Explicit
' ===================================================================
' 说明：将此代码放入标准模块（Module）中；
' 在 UserForm 的各事件中调用 ManageEmployeeForm 并传入对应 action 即可。
' Private Sub UserForm_Initialize(): Call ManageEmployeeForm("Init", Me): End Sub
' Private Sub cmdSubmit_Click(): Call ManageEmployeeForm("Submit", Me): End Sub
' Private Sub cmdClear_Click(): Call ManageEmployeeForm("Clear", Me): End Sub
' ===================================================================
Public Sub ManageEmployeeForm(ByVal action As String, ByRef frm As Object)
Const TARGET_SHEET_NAME As String = "Sheet1"
Const COL_EMP_NAME As Long = 1
Const COL_DEPT As Long = 2
Const COL_JOIN_DATE As Long = 3
Const DATE_FORMAT As String = "YYYY-MM-DD"
On Error GoTo ErrHandler
Select Case action
Case "Init"
' 初始化部门下拉框选项
With frm.cboDept
.Clear
.AddItem "销售"
.AddItem "技术"
.AddItem "财务"
.AddItem "HR"
End With
Case "Submit"
' ---- 输入验证 ----
Dim empName As String
empName = Trim(frm.txtEmpName.Value)
If empName = "" Then
MsgBox "请填写员工姓名。", vbExclamation, "验证失败"
frm.txtEmpName.SetFocus
Exit Sub
End If
If frm.cboDept.ListIndex = -1 Then
MsgBox "请选择部门。", vbExclamation, "验证失败"
frm.cboDept.SetFocus
Exit Sub
End If
Dim joinDateStr As String
joinDateStr = Trim(frm.txtJoinDate.Value)
If Not IsDate(joinDateStr) Then
MsgBox "入职日期格式不正确，请使用 " & DATE_FORMAT & " 格式。", vbExclamation, "验证失败"
frm.txtJoinDate.SetFocus
Exit Sub
End If
' ---- 写入工作表 ----
If MsgBox("确认提交员工「" & empName & "」的信息？", vbYesNo + vbQuestion, "提交确认") = vbNo Then
Exit Sub
End If
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
Dim nextRow As Long
nextRow = ws.Cells(ws.Rows.Count, COL_EMP_NAME).End(xlUp).Row + 1
ws.Cells(nextRow, COL_EMP_NAME).Value = empName
ws.Cells(nextRow, COL_DEPT).Value = frm.cboDept.Value
ws.Cells(nextRow, COL_JOIN_DATE).Value = CDate(joinDateStr)
ws.Cells(nextRow, COL_JOIN_DATE).NumberFormat = DATE_FORMAT
MsgBox "员工「" & empName & "」信息已成功录入第 " & nextRow & " 行。", vbInformation, "提交成功"
' 提交成功后自动清空表单
Call ManageEmployeeForm("Clear", frm)
Case "Clear"
frm.txtEmpName.Value = ""
frm.cboDept.ListIndex = -1
frm.txtJoinDate.Value = ""
frm.txtEmpName.SetFocus
End Select
Exit Sub
ErrHandler:
MsgBox "发生错误：" & Err.Description & " (错误代码: " & Err.Number & ")", vbCritical, "错误"
End SubA single Sub handles all UserForm events (Init/Submit/Clear) with full input validation (non-empty, date format check), confirmation dialog before writing, and auto-clear after successful submission.
Fix Silent Error Suppression
Prompt
The macro runs without errors but data isn't processed correctly — no idea where it's going wrong.
Sub ProcessSales()
On Error Resume Next
Dim ws As Worksheet
Set ws = Sheets("销售数据")
Dim i As Integer
For i = 2 To 1000
Dim val As Integer
val = CInt(ws.Cells(i, 3).Value)
ws.Cells(i, 4).Value = val * 0.15
Next i
MsgBox "处理完成"
End SubRemoved On Error Resume Next and replaced with proper error handling; changed Integer to Double to prevent overflow; added IsNumeric checks that skip and flag non-numeric rows instead of silently writing wrong values.
Fix Integer Overflow
Prompt
Runtime error 6: Overflow when the sheet has more than 30,000 rows.
Sub ScanAllRows()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim totalRows As Integer
totalRows = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
Dim total As Integer
For i = 1 To totalRows
If ws.Cells(i, 1).Value > 0 Then
total = total + ws.Cells(i, 2).Value
End If
Next i
ws.Range("D1").Value = total
End SubChanged all row-counting variables from Integer to Long (supports ~2 billion), changed accumulator to Double to prevent value overflow, and added IsNumeric checks to handle text cells safely.
Fix Early Binding Cross-Version Error
Prompt
Macro fails on other users' machines due to different Office versions — early binding reference mismatch.
Sub SendReport()
Dim outlookApp As Outlook.Application
Dim mail As Outlook.MailItem
Set outlookApp = New Outlook.Application
Set mail = outlookApp.CreateItem(olMailItem)
With mail
.To = "[email protected]"
.Subject = "月度报告"
.Body = "请查收本月报告附件"
.Attachments.Add "C:\Reports\monthly.xlsx"
.Send
End With
End SubSwitched from Early Binding to CreateObject Late Binding and manually defined the olMailItem constant — the macro now runs on any Office version without any VBE reference dependencies.
Generate Your Own VBA Code
Describe your task in plain language and get production-quality VBA in seconds. Sign up free for 30 credits.
Start for freeVBACODE.AI