【Excel】【VBA】根据某列的编号顺序筛选对应的行导入相应的sheet中

Excel VBA 数据分类导入sheet

1. 程序功能

将Excel表格数据按照PC编号分类到不同Sheet。

2. 程序流程

3. 主要子程序说明

3.1 SplitDataFaster()

主程序，控制整个数据分类流程。

• 获取工作表信息
• 调用其他子程序
• 处理数据分类逻辑

3.2 DeleteExistingSheets()

删除已存在的PC工作表。

3.3 CreateNewSheets()

创建新的分类工作表。

3.4 CopyHeaders()

复制表头到新工作表。

3.5 CopyRowToSheet()

复制数据行到指定工作表。

3.6 AdjustAllSheets()

调整所有工作表的列宽。

4. VBA语法和函数说明

4.1 常用声明

Dim ws As Worksheet        ' 工作表对象声明
Dim lastRow As Long        ' 长整型变量
Dim sheetNames As Variant  ' 变体类型数组

4.2 工作表操作

Set ws = ActiveSheet                          ' 获取活动工作表
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row  ' 获取最后一行
Worksheets.Add                                ' 添加新工作表
ws.Delete                                     ' 删除工作表

4.3 字符串处理

Left(string, length)       ' 获取左侧字符
Mid(string, start, length) ' 获取中间字符
InStr(string, substring)   ' 查找子字符串位置

4.4 数据复制

sourceWs.Rows(1).Copy destination  ' 复制整行

4.5 应用程序控制

Application.ScreenUpdating = False  ' 关闭屏幕刷新
Application.DisplayAlerts = False   ' 关闭警告提示

4.6 条件判断

If condition Then          ' IF语句
Select Case value          ' Select Case语句

4.7 循环结构

For Each ... In ...        ' 集合遍历
For i = start To end       ' 数值循环

5. 使用说明

1. 数据要求：

   • 第二列(B列)包含PC编号
   • PC编号格式：PC数字-xxx

2. 运行步骤：

   • 确保当前工作表为需要处理的数据表
   • 运行SplitDataFaster宏
   • 等待处理完成提示

3. 输出结果：

   • PC01_11：PC1-11的数据
   • PC12_22：PC12-22的数据
   • PC23_44：PC23-44的数据
   • PC45_67：PC45-67的数据
   • PC82：PC82的数据
   • PC83_87：PC83-87的数据
   • PC68_92：PC68-81和PC88-92的数据

6. 性能优化说明

• 关闭屏幕刷新提高运行速度
• 关闭警告消息避免中断
• 使用直接复制而非数组操作
• 统一处理工作表创建和删除

Sub SplitDataFaster()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim pcNum As Integer
    
    ' 设置当前工作表
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 删除现有的分组工作表
    DeleteExistingSheets
    
    ' 创建新工作表
    CreateNewSheets
    
    ' 复制标题行到每个新表
    CopyHeaders ws
    
    ' 处理每一行数据
    For i = 2 To lastRow
        If Left(ws.Cells(i, 2).Value, 2) = "PC" Then
            pcNum = CInt(Mid(ws.Cells(i, 2).Value, 3, InStr(ws.Cells(i, 2).Value, "-") - 3))
            
            ' 根据PC编号分组
            Select Case pcNum
                Case 1 To 11
                    CopyRowToSheet ws, i, "PC01_11"
                Case 12 To 22
                    CopyRowToSheet ws, i, "PC12_22"
                Case 23 To 44
                    CopyRowToSheet ws, i, "PC23_44"
                Case 45 To 67
                    CopyRowToSheet ws, i, "PC45_67"
                Case 82
                    CopyRowToSheet ws, i, "PC82"
                Case 83 To 87
                    CopyRowToSheet ws, i, "PC83_87"
                Case 68 To 81, 88 To 92
                    CopyRowToSheet ws, i, "PC68_92"
            End Select
        End If
    Next i
    
    ' 调整所有新工作表的列宽
    AdjustAllSheets
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "数据分类完成！", vbInformation
End Sub

Sub DeleteExistingSheets()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "PC*" Then
            ws.Delete
        End If
    Next ws
End Sub

Sub CreateNewSheets()
    Dim sheetNames As Variant
    Dim i As Long
    
    sheetNames = Array("PC01_11", "PC12_22", "PC23_44", "PC45_67", "PC82", "PC83_87", "PC68_92")
    
    For i = 0 To UBound(sheetNames)
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sheetNames(i)
    Next i
End Sub

Sub CopyHeaders(sourceWs As Worksheet)
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "PC*" Then
            sourceWs.Rows(1).Copy ws.Rows(1)
        End If
    Next ws
End Sub

Sub CopyRowToSheet(sourceWs As Worksheet, rowNum As Long, targetSheet As String)
    Dim targetRow As Long
    
    ' 获取目标工作表的下一个空行
    targetRow = Worksheets(targetSheet).Cells(Worksheets(targetSheet).Rows.Count, "B").End(xlUp).Row + 1
    
    ' 复制整行数据
    sourceWs.Rows(rowNum).Copy Worksheets(targetSheet).Rows(targetRow)
End Sub

Sub AdjustAllSheets()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "PC*" Then
            ws.Columns.AutoFit
        End If
    Next ws
End Sub

原文地址：https://blog.csdn.net/hmywillstronger/article/details/145111072

免责声明：本站文章内容转载自网络资源，如本站内容侵犯了原著者的合法权益，可联系本站删除。更多内容请关注自学内容网（zxcms.com）！