Snasui Excel Forum

Code: Select all

Public Sub Find_Hidden()
    Dim vfndVal As Variant
    Dim rfndRng As Range
    
    vfndVal = ActiveSheet.Range("c1").Value
    Set rfndRng = ActiveSheet.Columns("a:a").Find(what:=vfndVal, LookIn:=xlFormulas, lookat:=xlPart, _
                            searchorder:=xlNext, MatchCase:=False)
    
    If vfndVal = "" Then Exit Sub
    
    If rfndRng Is Nothing Then
        MsgBox "Not found!!!"
        Exit Sub
    Else
        MsgBox "ข้อมูลของคุณอยู่ที่เซลล์ " & rfndRng.Address
    End If
End Sub

Code: Select all

Public Sub Find_Hidden()
    Dim vfndVal As Variant
    Dim rfndRng As Range
    Dim r As Range
    Dim lRow As Long
    Dim t As String
    
    vfndVal = ActiveSheet.Range("c1").Value
    If vfndVal = "" Then Exit Sub
    lRow = ActiveSheet.UsedRange.Rows.Count
    Set rfndRng = Range("a2:a" & lRow)
    For Each r In rfndRng
        If r = vfndVal Then
           t = t & "," & r.Address(0, 0)
        End If
    Next r
    If t <> "" Then
        MsgBox "Your data found on cells " & Mid(t, 2)
    Else
        MsgBox "Not found"
    End If
End Sub

Code: Select all

Private Sub Product_AddNew()
    Dim sH7 As Worksheet, sTK As Worksheet, sPro As Worksheet
    Dim er As Integer, FndVal1 As Integer, FndVal2 As Integer, lstRow As Integer
    Dim pdGrp As Integer, untPck As Integer
    Dim bCode As Variant
    Dim intCd As Long
    Dim fndRng As Range
    Dim untNm As String
    Set sH7 = Sheets("7New")
    Set sTK = Sheets("STK")
    Set sPro = Sheets("Pro")
    intCd = sH7.Range("d6").Value
    bCode = sH7.Range("g6").Value
    er = Application.CountIf(sH7.Range("j3:j8"), "*?")
    
    '-----------------------------------
    'ตรวจสอบว่าพบ error หรือไม่
    '-----------------------------------
    If sH7.Range("b6") = 0 Or intCd = 0 Then
        MsgBox "ใส่รายละเอียดให้ครบก่อน"
        Exit Sub
    End If
    If er > 0 Then
        MsgBox "โปรดแก้ไขข้อผิดพลาด", vbCritical, "ERROR"
        Exit Sub
    End If
    
    '-----------------------------------------------
    'ตรวจรหัสบาร์โค้ด ไม่ให้ซ้ำกับฐานข้อมูลเก่า
    '-----------------------------------------------
    Application.ScreenUpdating = False
    
    FndVal1 = Application.CountIf(sTK.Columns("c:c"), intCd)
    If bCode <> "" Then
        FndVal2 = Application.CountIf(sTK.Columns("M:M"), bCode)
    Else
        FndVal2 = 0
    End If
    
    If FndVal1 + FndVal2 > 0 Then
        MsgBox "ข้อมูลซ้ำ! โปรดตรวจสอบรหัสภายในหรือบาร์โค้ดใหม่", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If

    '-----------------
    'เริ่มใส่ค่าตัวแปร
    '-----------------
    With sH7
        pdGrp = .Range("b6").Value
        untNm = .Range("e6").Value
        untPck = .Range("f6").Value
    End With
    
    '-------------------------------------------------
    'หาแถวสุดท้ายในชีท STK และใส่รายการสินค้า
    '-------------------------------------------------
    With sTK
        .Activate
        .Unprotect
        If .AutoFilterMode Then .AutoFilterMode = False
        lstRow = .Range("b" & Rows.Count).End(xlUp).Offset(1, 0).Row
        .Cells(lstRow, 2).Value = pdGrp
        .Cells(lstRow, 3).Value = intCd
        .Cells(lstRow, 4).Value = untNm
        .Cells(lstRow, 5).Value = untPck
        .Cells(lstRow, 13).Value = bCode
        .Cells(lstRow, 12).NumberFormat = "#,##0.00;[Red]-#,##0.00;0"
        .Cells(lstRow, 13).NumberFormat = "0"
        .Range(Cells(lstRow, 5), Cells(lstRow, 5).Offset(0, 6)).NumberFormat = "#,##0;[Red]-#,##0;"
        .Range(Cells(lstRow, 14), Cells(lstRow, 15)).NumberFormat = "#,##0.00;[Red]-#,##0.00;0"
        .Range(Cells(lstRow, 2), Cells(lstRow, 3)).HorizontalAlignment = xlCenter
        
        '-------------
        'Add formulas
        '-------------
        .Range("v5").Copy
            .Cells(lstRow, 1).PasteSpecial Paste:=xlPasteFormulas
        .Range("w5:ac5").Copy
            .Cells(lstRow, 6).PasteSpecial Paste:=xlPasteFormulas
        .Range("ad5:ak5").Copy
            .Cells(lstRow, 14).PasteSpecial Paste:=xlPasteFormulas
            
        '--------------
        'เปลี่ยน font
        '--------------
        With .Range(Cells(lstRow, 1), Cells(lstRow, 1).Offset(0, 14)).Font
                .Name = "BrowalliaUPC"
                .Size = 14
                .TintAndShade = 0
        End With
        
        '--------
        'ตีกรอบ
        '--------
        With .Range(.Cells(lstRow, "a"), .Cells(lstRow, "o")).Borders
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlHairline
        End With
        
        '//ใส่สีช่องคงเหลือ//
        With .Range(Cells(lstRow, 10), Cells(lstRow, 11)).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 6750207
                .TintAndShade = 0
                .PatternTintAndShade = 0
        End With
        
        '-----------
        'เรียงลำดับ
        '-----------
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("b" & lstRow) _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=Range("c" & lstRow) _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                With .Sort
                        .SetRange Range("B5:U" & lstRow)
                        .Header = xlYes
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                End With
                
        If Not .AutoFilterMode Then .Range("a5:u" & lstRow).AutoFilter
        .Protect , AllowFiltering:=True
    End With
    
    '//Add product to pro sheet
    With sPro
        .Activate
        .Unprotect
        .Columns("a:a").EntireRow.Hidden = False
        lstRow = .Range("b" & Rows.Count).End(xlUp).Offset(1, 0).Row
        
        .Cells(lstRow, 1).Value = pdGrp
        .Cells(lstRow, 2).Value = intCd
        .Cells(lstRow, 2).HorizontalAlignment = xlCenter
        .Cells(lstRow, 3).Value = untNm
        .Cells(lstRow, 4).Value = Format(untPck, "#,##0")
        .Cells(lstRow, 6).NumberFormat = "#,##0"
        .Cells(lstRow, 6).Locked = False
        
        With .Range(.Cells(lstRow, 1), .Cells(lstRow, 10)).Borders
            .LineStyle = xlContinuous
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
        End With
        
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("a4") _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("b4") _
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                With .Sort
                    .SetRange Range("a4:j" & lstRow)
                    .Header = xlYes
                    .Orientation = xlTopToBottom
                    .MatchCase = False
                    .Apply
                End With
        Set fndRng = .Columns("b:b").Find(what:=intCd, lookat:=xlWhole)
        fndRng.Offset(0, 4).Select
        .Protect
        .EnableSelection = xlUnlockedCells
    End With
    
    sH7.Range("b6,d6:g6").ClearContents
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "เพิ่มสินค้าใหม่เรียบร้อย"
End Sub

Code: Select all

Private Sub Worksheet_Calculate()
    Dim r As Range, rRunNo As Range
    Dim i As Integer
    Set rRunNo = ActiveSheet.Range("A2", Range("a2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible)

    i = 0
    For Each r In rRunNo
        i = i + 1
        r = i
    Next r

End Sub

Code: Select all

Private Sub Worksheet_Calculate()
    Dim r As Range, rRunNo As Range
    Dim i As Integer
    Application.EnableEvents = False
    With ActiveSheet
        Set rRunNo = .Range("A2", .Range("a2").End(xlDown)) _
            .SpecialCells(xlCellTypeVisible)
    End With
    i = 0
    For Each r In rRunNo
        i = i + 1
        r = i
    Next r
    Application.EnableEvents = True
End Sub

Code: Select all

Application.EnableEvents = False
...
Application.EnableEvents = True

Code: Select all

Private Sub Worksheet_Calculate()
    Dim imax As Integer, i As Integer
    Dim wSTK As Worksheet
    Dim r As Range, rRunNo As Range
    If ActiveSheet.Name <> "STK" Then Exit Sub
    ...
End Sub