Excel VBA实现工作表数据同步至SQL数据库的技术问询

本人是VBA新手，需要实现将CRM每日更新的CSV导入Excel后，同步数据到SQL数据库，具体要求：

1. 数据库表名与工作表名一致
2. 忽略首字符为#、'、_的行
3. 自动识别新增列（所有列存为字符串）并同步
4. 自动遍历所有工作表，新增工作表自动在数据库建表同步
5. 仅同步变更数据，避免重复录入
6. 空单元格存入数据库为空字段

现有测试代码可运行，但未实现忽略指定行的逻辑，现咨询：

• 能否用条件语句实现忽略行的需求？有没有更优方案？
• 如何实现自动识别新增列并同步？
• 如何遍历所有工作表并自动建表？
• 如何实现仅同步变更、避免重复录入？

一、忽略指定首字符的行：条件判断+批量过滤两种方案 #

完全可以用条件语句实现，根据数据量大小选不同方案：

方案1：逐行判断（适合小数据集） #

遍历行时用Left()函数提取第一列首字符，直接判断是否跳过：

Dim ws As Worksheet
Dim lastRow As Long, i As Long
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

For i = 2 To lastRow '假设第一行是表头
    Dim firstChar As String
    firstChar = Left(Trim(ws.Cells(i, 1).Value), 1)
    '判断是否为需忽略的字符
    If Not (firstChar = "#" Or firstChar = "'" Or firstChar = "_") Then
        '这里写你的数据同步逻辑
        SyncRowToSQL ws, i
    End If
Next i

方案2：AutoFilter批量过滤（适合大数据集） #

先过滤掉无效行，再处理可见行，避免逐行循环的性能损耗：

Dim ws As Worksheet
Dim rng As Range, filteredRng As Range
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & lastRow)

'应用筛选：排除首字符为#、'、_的行
rng.AutoFilter Field:=1, Criteria1:="<>#*", Operator:=xlAnd, _
               Criteria2:="<>_*", Operator:=xlAnd, Criteria3:="<>'" & "*"

'获取筛选后的有效行（跳过表头）
On Error Resume Next
Set filteredRng = rng.Offset(1, 0).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not filteredRng Is Nothing Then
    For Each cell In filteredRng
        'cell.Row就是有效行号，执行同步逻辑
        SyncRowToSQL ws, cell.Row
    Next cell
End If

'关闭筛选
ws.AutoFilterMode = False

二、自动识别新增列并同步 #

核心是对比数据库现有列与Excel表头，新增列就执行ALTER TABLE添加，所有列设为VARCHAR(MAX)（满足字符串存储要求）：

Sub SyncColumnsToSQL(ws As Worksheet, conn As ADODB.Connection, tableName As String)
    Dim dbColumns As Dictionary
    Set dbColumns = CreateObject("Scripting.Dictionary") '无需额外引用
    
    '1. 读取数据库表的现有列
    Dim rs As ADODB.Recordset
    Set rs = conn.OpenSchema(adSchemaColumns, Array(Empty, Empty, tableName))
    Do While Not rs.EOF
        dbColumns.Add rs!COLUMN_NAME, True
        rs.MoveNext
    Loop
    rs.Close
    
    '2. 遍历Excel表头，新增数据库不存在的列
    Dim lastCol As Long, j As Long
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For j = 1 To lastCol
        Dim colName As String
        colName = ws.Cells(1, j).Value
        If Not dbColumns.Exists(colName) Then
            Dim alterSql As String
            alterSql = "ALTER TABLE [" & tableName & "] ADD [" & colName & "] VARCHAR(MAX)"
            conn.Execute alterSql
        End If
    Next j
End Sub

三、遍历所有工作表并自动建表 #

遍历ThisWorkbook.Worksheets集合，先检查表是否存在，不存在则根据Excel表头创建新表：

Sub SyncAllWorksheets(conn As ADODB.Connection)
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        Dim tableName As String
        tableName = ws.Name
        
        '检查表是否存在
        If Not CheckTableExists(conn, tableName) Then
            '根据工作表表头创建新表
            CreateTableFromWorksheet ws, conn, tableName
        End If
        
        '同步列和数据
        SyncColumnsToSQL ws, conn, tableName
        SyncRowsToSQL ws, conn, tableName '结合行过滤的数据同步逻辑
    Next ws
End Sub

'辅助函数：检查表是否存在
Function CheckTableExists(conn As ADODB.Connection, tableName As String) As Boolean
    Dim rs As ADODB.Recordset
    On Error Resume Next
    Set rs = conn.OpenSchema(adSchemaTables, Array(Empty, Empty, tableName))
    CheckTableExists = Not rs.EOF
    rs.Close
End Function

'辅助函数：根据工作表创建SQL表
Sub CreateTableFromWorksheet(ws As Worksheet, conn As ADODB.Connection, tableName As String)
    Dim lastCol As Long, j As Long
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Dim createSql As String
    createSql = "CREATE TABLE [" & tableName & "] ("
    
    '拼接列定义
    For j = 1 To lastCol
        Dim colName As String
        colName = ws.Cells(1, j).Value
        createSql = createSql & "[" & colName & "] VARCHAR(MAX),"
    Next j
    '移除末尾多余的逗号
    createSql = Left(createSql, Len(createSql) - 1) & ")"
    
    conn.Execute createSql
End Sub

四、仅同步变更数据（增量同步） #

核心依赖唯一标识列（比如CRM的主键ID），没有的话可以用多列组合成唯一键。步骤：读取数据库已有唯一键及对应数据，对比Excel行，新增则插入，有变更则更新：

Sub SyncRowsToSQL(ws As Worksheet, conn As ADODB.Connection, tableName As String)
    Dim existingKeys As Dictionary
    Set existingKeys = CreateObject("Scripting.Dictionary")
    Dim rs As ADODB.Recordset
    
    '1. 读取数据库所有记录的唯一键和整行数据
    Set rs = conn.Execute("SELECT * FROM [" & tableName & "]")
    Do While Not rs.EOF
        Dim keyVal As String
        keyVal = rs.Fields(0).Value '假设第一列是唯一键
        '把整行数据转成字符串，方便对比
        Dim rowStr As String
        rowStr = ""
        For Each fld In rs.Fields
            rowStr = rowStr & "|" & Nz(fld.Value, "")
        Next fld
        existingKeys.Add keyVal, rowStr
        rs.MoveNext
    Loop
    rs.Close
    
    '2. 遍历Excel有效行（结合行过滤）
    Dim lastRow As Long, i As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        Dim firstChar As String
        firstChar = Left(Trim(ws.Cells(i, 1).Value), 1)
        If Not (firstChar = "#" Or firstChar = "'" Or firstChar = "_") Then
            Dim excelKey As String
            excelKey = ws.Cells(i, 1).Value
            Dim excelRowStr As String
            excelRowStr = ""
            Dim lastCol As Long, j As Long
            lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
            
            '拼接Excel行的字符串
            For j = 1 To lastCol
                excelRowStr = excelRowStr & "|" & Nz(ws.Cells(i, j).Value, "")
            Next j
            
            If Not existingKeys.Exists(excelKey) Then
                '插入新记录
                InsertRow ws, conn, tableName, i
            Else
                '数据有变更则更新
                If existingKeys(excelKey) <> excelRowStr Then
                    UpdateRow ws, conn, tableName, i
                End If
            End If
        End If
    Next i
End Sub

'辅助函数：插入行
Sub InsertRow(ws As Worksheet, conn As ADODB.Connection, tableName As String, rowNum As Long)
    Dim lastCol As Long, j As Long
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Dim insertSql As String, valuesSql As String
    insertSql = "INSERT INTO [" & tableName & "] ("
    valuesSql = "VALUES ("
    
    For j = 1 To lastCol
        Dim colName As String, val As String
        colName = ws.Cells(1, j).Value
        val = Replace(ws.Cells(rowNum, j).Value, "'", "''") '转义单引号
        insertSql = insertSql & "[" & colName & "],"
        valuesSql = valuesSql & "'" & val & "',"
    Next j
    insertSql = Left(insertSql, Len(insertSql) - 1) & ")"
    valuesSql = Left(valuesSql, Len(valuesSql) - 1) & ")"
    
    conn.Execute insertSql & " " & valuesSql
End Sub

'辅助函数：更新行
Sub UpdateRow(ws As Worksheet, conn As ADODB.Connection, tableName As String, rowNum As Long)
    Dim lastCol As Long, j As Long
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Dim updateSql As String
    updateSql = "UPDATE [" & tableName & "] SET "
    Dim keyVal As String
    keyVal = ws.Cells(rowNum, 1).Value '唯一键
    
    For j = 2 To lastCol '跳过唯一键列
        Dim colName As String, val As String
        colName = ws.Cells(1, j).Value
        val = Replace(ws.Cells(rowNum, j).Value, "'", "''")
        updateSql = updateSql & "[" & colName & "]='" & val & "',"
    Next j
    updateSql = Left(updateSql, Len(updateSql) - 1) & " WHERE [" & ws.Cells(1, 1).Value & "]='" & keyVal & "'"
    
    conn.Execute updateSql
End Sub

'辅助函数：处理空值，转为空字符串
Function Nz(val As Variant, Optional replaceVal As String = "") As String
    If IsNull(val) Or val = "" Then
        Nz = replaceVal
    Else
        Nz = CStr(val)
    End If
End Function

内容的提问来源于stack exchange，提问作者Chewbacca