Snasui Excel Forum

Code: Select all

Private Sub TotMainStk()
    Dim i%, lRw%, iiTem%, sWhen!, sRem!
    Set WsStk = Sheets("stk")
    With Application
        .EnableEvents = False
        .Application.Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    With WsStk
        iiTem = .Range("a4").Value
        .Unprotect Password:="123"
        If .AutoFilterMode Then .AutoFilterMode = False
        If Not .AutoFilterMode Then .Range("n6:u6").AutoFilter
        .Protect Password:="123", AllowFiltering:=True
        .EnableSelection = xlUnlockedCells
    End With
    With ActiveSheet
        .Unprotect Password:="123"
        sWhen = Now()
        If .Range("e5") > 0 Then sWhen = .Range("e5")
        If .AutoFilterMode Then .AutoFilterMode = False
        lRw = Application.WorksheetFunction.Max _
                (7, .Range("b" & .Rows.Count).End(xlUp).Row)
        .Range("a7:p" & lRw).Clear
        'สร้างรายการสินค้า
        .Range("e5").Value = sWhen
        .Range("b7:e" & iiTem + 6).Value = WsStk.Range("b7:e" & iiTem + 6).Value
        .Range("f7:f" & iiTem + 6).Value = WsStk.Range("u7:u" & iiTem + 6).Value
        WsStk.Range("t1").Value = sWhen
        'เรียงคลัง C1
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        WsStk.Range("b3") = "C1"
        .Range("k7:l" & iiTem + 6).Value = WsStk.Range("j7:k" & iiTem + 6).Value
        .Range("q7:q" & iiTem + 6).Value = WsStk.Range("l7:l" & iiTem + 6).Value
        'เรียกคลัง M1
        WsStk.Range("b3") = "M1"
        .Range("m7:n" & iiTem + 6).Value = WsStk.Range("j7:k" & iiTem + 6).Value
        .Range("r7:r" & iiTem + 6).Value = WsStk.Range("l7:l" & iiTem + 6).Value
        'คัดลอกรูปแบบและสูตร
        Application.EnableEvents = False
        .Range("g3:j3").Copy
        .Range("g7:j" & iiTem + 6).PasteSpecial xlPasteFormulas
        Application.Calculation = xlCalculationManual
        .Range("g7:j" & iiTem + 6).Value = .Range("g7:j" & iiTem + 6).Value
        .Range("a2:p2").Copy
        .Range("a7:p" & iiTem + 6).PasteSpecial xlPasteFormats

        For i = iiTem + 6 To 7 Step -1
            If .Cells(i, "f").Value + .Cells(i, "g").Value + .Cells(i, "h").Value = 0 Then
                .Rows(i).Delete Shift:=xlUp
            Else
            sRem = .Cells(i, "g").Value + .Cells(i, "h").Value / .Cells(i, "e").Value
                With .Range("a" & i, .Range("b" & i)).Font
                    If sRem = 0 Then
                        .Color = vbRed
                        .Bold = True
                        ActiveSheet.Cells(i, "p") = "หมด"
                    ElseIf sRem < ActiveSheet.Cells(i, "f").Value Then
                        .Color = RGB(0, 0, 255)
                        .Bold = True
                        ActiveSheet.Cells(i, "p") = "ใกล้หมด"
                    Else
                        .Color = vbBlack
                    End If
                End With
                'If .Cells(i, "g").Value + .Cells(i, "h").Value = 0 Then .Cells(i, "p") = "หมด"
                .Cells(i, "o").Value = .Cells(i, "q") + .Cells(i, "r")
            End If
        Next i
        For i = 7 To .Range("b" & .Rows.Count).End(xlUp).Row
            .Cells(i, "a").Value = i - 6
        Next i
        .Range("a5").Value = i - 7
        .Range("c6").Select
        If Not .AutoFilterMode Then .Range("a6:p6").AutoFilter
        .PageSetup.PrintArea = "$A$1:$J$" & i - 1
        .Protect Password:="123", AllowFiltering:=True
        .EnableSelection = xlNoRestrictions
    End With
    Call ActivateEvent
    Application.ScreenUpdating = True
End Sub

Code: Select all

Private Sub Worksheet_Calculate()
    Dim r As Range, rVis As Range, i%, j%
    On Error GoTo fnderrorout:
    If ActiveSheet.Name <> Me.Name Then Exit Sub
    'ใส่ลำดับสินค้าใหม่
    Set WsStk = Sheets("stk")
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    With WsStk
        .Unprotect ("123")
        i = .Range("a4").Value
        j = 1
        Set rVis = .Range("a7:a" & i + 6).SpecialCells(xlCellTypeVisible)
        For Each r In rVis
            r.Value = j
            j = j + 1
        Next r
        .Range("u7:u" & i).Locked = False
        .PageSetup.PrintArea = "$A$1:$K$" & i + 6
        .Protect ("123"), AllowFiltering:=True
        .EnableSelection = xlUnlockedCells
    End With
    Call ActivateEvent
    Application.ScreenUpdating = True
fnderrorout: 'จัดการข้อผิดพลาดกรณีเปิดไฟล์อื่น
End Sub

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i%
    Set WsStk = ThisWorkbook.Sheets("stk")
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    If Target.Address(0, 0) = "B3" Or Target.Address(0, 0) = "T1" Then
        With WsStk
            .Unprotect ("123")
            i = .Range("a4").Value
            If .AutoFilterMode Then .AutoFilterMode = False
            .Range("o5:s5").Copy
            .Range("o7:s" & i + 6).PasteSpecial xlPasteFormulas
            .Range("f5:m5").Copy
            .Range("f7:m" & i + 6).PasteSpecial xlPasteFormulas
            With .Range("f7:s" & i + 6)
                .Value = .Value
            End With
            If Not .AutoFilterMode Then .Range("a6:u6").AutoFilter
            .Protect ("123"), AllowFiltering:=True
            .EnableSelection = xlUnlockedCells
            If ActiveSheet.Name = "STK" Then .Range("b3").Select
        End With
    ElseIf Target.Row > 6 And Target.Column = 14 Then
        Dim tR&, iP!
            With WsStk
                If Not IsNumeric(Target.Value) Then
                    MsgBox "โปรดคีย์เป็นตัวเลขเท่านั้น", vbCritical
                    Target.ClearContents
                Else
                    iP = Target.Value
                    tR = Target.Row
                    .Cells(tR, "l").Value = .Cells(tR, "s") * iP / .Cells(tR, "e")
                End If
            End With
    End If
    With Application
        .EnableEvents = True
        If ActiveSheet.Name = "STK" Then .ScreenUpdating = True
    End With
End Sub

Code: Select all

'Other code
Sheets("Main").Activate
For i = iiTem + 6 To 7 Step -1
'Other code