VBA多级联动更新代码

Option Explicit

Sub updateList()
    Application.ScreenUpdating = False '取消屏幕闪烁
    Dim i As Integer '循环index
    Dim j As Integer '横向index
    Dim k As Integer '输出index
    k = 2 '设置辅助表行数初始值
    For i = 1 To ThisWorkbook.Names.Count
        ThisWorkbook.Names(1).Delete '循环删除名称管理器中内容
    Next
    With Sheet1
        '第一部分
        .Range("L:IV").ClearContents '删除L列到最后一列的内容
        For i = 2 To .Range("I" & 2 ^ 16).End(xlUp).Row '从第2行开始直到【工序】列最后一位不为空的值所在行
            If .Range("G" & i).Value <> "" Then '如果【名称】列当前值不为空
                j = 13 '则使列初始值为13,也就是L列
                .Range("L" & k).Value = .Range("G" & i).Value 'L列输入G列内容即——"名称"
                If i > 2 Then '当获取行数大于2时,也就是从基础数据表第3行开始获取时
                    .Cells(k, j).Value = .Range("H" & i).Value '横向填充【图号】列内容。同时满足【名称】列当前行不为空的条件
                    .Cells(2, .Range("IV2").End(xlToLeft).Column + 1).Value = .Range("G" & i).Value '横向填充【名称】列内容
                End If
                k = k + 1 '执行完后,行数值+1
            ElseIf .Range("H" & i).Value <> "" Then '否则如果【图号】列当前行不为空时,此时为避免该列中存在多个合并单元格的情况出现
                j = j + 1 '列号+1,也就是往右平移一个位置
                If i > 2 Then .Cells(k - 1, j).Value = .Range("H" & i).Value '横向填充【图号】列内容
            End If
        Next
        '第二部分
        For i = 3 To .Range("I" & 2 ^ 16).End(xlUp).Row '从第3行开始直到【工序】列最后一位不为空的值所在行
            If .Range("H" & i).Value <> "" Then '如果【图号】列当前值不为空
                j = 13 '则使列初始值为13,也就是L列
                .Range("L" & k).Value = .Range("H" & i).Value '纵向填充【图号】列内容,初始行数值k由上述循环结果决定,接下来的k值由本次循环结果决定
                .Cells(k, j).Value = .Range("I" & i).Value '横向填充【工序】列内容
                k = k + 1
            Else
                j = j + 1 '否则,列号+1,也就是往右平移一个位置
                .Cells(k - 1, j).Value = .Range("I" & i).Value '横向填充【工序】列内容
            End If
        Next
        '定义名称
        .Range("L:IV").SpecialCells(xlCellTypeConstants, 23).CreateNames False, True, False, False '创建名称
    End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    updateList
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    '更新列表
    If Target.Column = 2 And Target.Row > 2 Then
        ActiveCell.Offset(0, 1).Value = ""
        ActiveCell.Offset(0, 2).Value = ""
    ElseIf Target.Column = 3 And Target.Row > 2 Then
        ActiveCell.Offset(0, 1).Value = ""
    End If
    '更新辅助表
    If Target.Column > 6 And Target.Column < 11 And Target.Row > 1 Then
        updateList
    End If
End Sub

猜你喜欢

转载自blog.csdn.net/qq_18301257/article/details/80555901