Snasui Excel Forum

Code: Select all

Sub ShowDataTraining()
    On Error Resume Next
    Application.EnableEvents = False
    Sheets("Database").Range("A3:K100").AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")
    Sheets("Database").Range("A4:K100").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

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

Code: Select all

Option Explicit
Option Base 1

Sub ShowDataTraining()
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("B4", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
    If r = Worksheets("Search").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) = r.Offset(0, 4)
        a(8, lng) = r.Offset(0, 5)
        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("Search")
        Set rt = .Range("B12", .Range("Q" & lng - 1 + 12))
        If .Range("B12") <> "" Then 'Check if isblank
             .Range("B12", .Range("B" & rl).End(xlUp).Offset(0, 4)).ClearContents
        End If
        .Range("B12:M12").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("D12", .Range("D" & rl).End(xlUp)).NumberFormat = "00000"
        .Range(.Range("B11").End(xlDown).Offset(1, 0), .Range("Q" & rl)).Clear 'Change new start cell
        .Range("F4").Activate
    End With
Else
    MsgBox "Data not found."
End If
'Range("A5:E5").AutoFilter
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Code: Select all

Sheets("Database").Range("A3:K100").AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")

Code: Select all

Sheets("Database").Range("A3",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") Then

Code: Select all

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