Snasui Excel Forum

Code: Select all

Sheets("Database").Range("A3",Sheets("Database").Range("K" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")

Code: Select all

For Each r In rAll
    If r = Worksheets("Search").Range("F5") And r.Offset(0,1) = Worksheets("Search").Range("F6") Then

Code: Select all

Sub ShowDataTraining()
    On Error Resume Next
    Application.EnableEvents = False
    Sheets("Search").Range("C12:M65536").ClearContents
    Sheets("Database").Range("A3", Sheets("Database"). _
        Range("A" & Rows.Count).End(xlUp).Offset(0, 11)).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")
    Sheets("Database").Range("A4", Sheets("Database"). _
        Range("A" & Rows.Count).End(xlUp).Offset(0, 11)).SpecialCells(xlCellTypeVisible).Copy
    Sheets("Search").Range("C12").PasteSpecial xlPasteValues
    Sheets("Database").ShowAllData
    Range("F4").Activate
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

Code: Select all

For Each r In rAll
    If r = Worksheets("Search").Range("F5") And r.Offset(0, -1) = Worksheets("Search").Range("F6") Then

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Address = "$F$4" And Target <> "" Then
           ShowDataTraining
       ElseIf Target.Address = "$F$6" And Target <> "" Then
           ShowDataTraining
      ElseIf Target.Address = "$F$4" And Target = "" Then
           MsgBox "Please select data."
End If
End Sub

Code: Select all

Option Explicit
Option Base 1

Sub ShowDataTraining1()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Dim m As Variant, i As Integer
Sheets("Search1").Range("B11:M65536").ClearContents
m = Array("มกราคม", "กุมภาพันธ์", "มีนาคม", "เมษายน", _
    "พฤษภาคม", "มิถุนายน", "กรกฎาคม", "สิงหาคม", _
    "กันยายน", "ตุลาคม", "พฤศจิกายน", "ธันวาคม")
i = Application.Match(Sheets("Search1").Range("F4"), m, 0)
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("Database")
    Set rAll = .Range("B4", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
    If Month(r.Offset(0, 4)) = i And r.Offset(0, -1) = Worksheets("Search1").Range("F5") Then
        lng = lng + 1
        ReDim Preserve a(12, lng)
        a(1, lng) = lng
        a(2, lng) = r.Offset(0, -1)
        a(3, lng) = r.Offset(0, 0)
        a(4, lng) = r.Offset(0, 1)
        a(5, lng) = r.Offset(0, 2)
        a(6, lng) = r.Offset(0, 3)
        a(7, lng) = Application.Text(r.Offset(0, 4), "mm/dd/yyyy")
        a(8, lng) = Application.Text(r.Offset(0, 5), "mm/dd/yyyy")
        a(9, lng) = r.Offset(0, 6)
        a(10, lng) = r.Offset(0, 7)
        a(11, lng) = r.Offset(0, 8)
        a(12, lng) = r.Offset(0, 9)
       
    End If
Next r
If lng > 0 Then
  With Worksheets("Search1")
        Set rt = .Range("B11", .Range("M" & lng - 1 + 11))
        If .Range("B11") <> "" Then 'Check if isblank
             .Range(.Range("B11"), .Range("B" & rl).End(xlUp)).Offset(0, 4).ClearContents
        End If
        .Range("B11:M12").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
    End With
Else
    MsgBox "Data not found."
End If
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$F$4" And Target <> "" Then
    ShowDataTraining1
ElseIf Target.Address = "$F$4" And Target = "" Then
    MsgBox "Please select data."
  End If
End Sub

Code: Select all

If Target.Address = "$F$4" And Target <> "" Then

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
      If Not Intersect(Target, Range("F4:F5")) Is Nothing Then
        Call ShowDataTraining1
End If
End Sub

Code: Select all

Set rt = .Range("B11", .Range("M" & lng - 1 + 11))

Code: Select all

Set rt = .Range("B11", .Range("N" & lng - 1 + 11))

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "F4" And Target <> "" Then
    ShowDataTraining1
ElseIf Target.Address = "F4" And Target = "" Then
    MsgBox "Please select data."
      
End If
End Sub

Code: Select all

If Target.Address = "$F$4" And Target <> "" Then

Code: Select all

If Target.Range("A1").Address = "$F$4" And Target.Range("A1") <> "" Then

Code: Select all

Option Explicit
Option Base 1

Sub ShowDetail()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("Database")
    Set rAll = .Range("B2", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
    If r = Worksheets("Looks").Range("D6") Then
        lng = lng + 1
        ReDim Preserve a(lng, 6)
        a(lng, 1) = lng
        a(lng, 2) = r.Offset(0, -1)
        a(lng, 3) = r.Offset(0, 0)
        a(lng, 4) = r.Offset(0, 1)
        a(lng, 5) = r.Offset(0, 2)
        a(lng, 6) = r.Offset(0, 3)
    End If
Next r
If lng > 0 Then
    With Worksheets("Looks")
        Set rt = .Range("C7", .Range("C" & lng + 1))
        .Range("C7", .Range("C" & rl).End(xlUp).Offset(0, 4)).ClearContents
        .Range("C8:C13").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("D6").Activate
    End With
Else
    MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Code: Select all

Option Explicit
Option Base 1

Sub ShowDetail()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("Database")
    Set rAll = .Range("B2", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
    If r = Worksheets("Looks").Range("D6") Then
        lng = lng + 1
        ReDim Preserve a(lng, 6)
'        a(lng, 1) = lng
        a(lng, 1) = r.Offset(0, -1)
        a(lng, 2) = r.Offset(0, 0)
        a(lng, 3) = r.Offset(0, 1)
        a(lng, 4) = r.Offset(0, 2)
        a(lng, 5) = r.Offset(0, 3)
        a(lng, 6) = r.Offset(0, 4)
    End If
Next r
If lng > 0 Then
    With Worksheets("Looks")
        Set rt = .Range("C8").Resize(6, 1)
        .Range("C8", .Range("C" & rl).End(xlUp).Offset(0, 4)).ClearContents
'        .Range("C8:C13").Copy
'        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("D6").Activate
    End With
Else
    MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub