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

發表評論
所有評論
還沒有人評論,想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.
相關文章