Snasui Excel Forum

Code: Select all

Option Explicit
Option Base 1
Sub ShowData()
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("Update").Range("K3") Then
        lng = lng + 1
        ReDim Preserve a(8, lng)
        a(8, lng) = lng
        a(1, lng) = r.Offset(0, 0)
        a(2, lng) = r.Offset(0, 1)
        a(3, lng) = r.Offset(0, 2)
        a(4, lng) = r.Offset(0, 3)
        a(5, lng) = r.Offset(0, 4)
        a(6, lng) = r.Offset(0, 5)
        a(7, lng) = r.Offset(0, 6)
    End If
Next r
If lng > 0 Then
    With Worksheets("Update")
        Set rt = .Range("A4", .Range("H" & lng - 1 + 4))
        .Range("A4", .Range("H" & rl)).ClearContents
        .Range("A4:H4").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("B4", .Range("B" & rl).End(xlUp)).NumberFormat = "00"
        .Range(.Range("B3").End(xlDown).Offset(1, 0), .Range("H" & rl)).Clear
    End With
Else
    MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Code: Select all

For Each rs In rsAll
    For i = rtAll.Count To 1 Step -1
    
        If rs = rtAll(i) And rs.Offset(0, 8) = rtAll(i).Offset(0, 8) _
        And rs.Offset(0, 4) = "Update" Then
            rs.Offset(0, 8).Resize(1, 8).Copy
            rtAll(i).Offset(0, 8).PasteSpecial xlPasteValues
        End If

Code: Select all

If rs = rtAll(i) And rs.Offset(0, 8) = rtAll(i).Offset(0, 8) _

Code: Select all

And rs.Offset(0, 4) = "Update" Then

Code: Select all

Sub Button2_Click()
Dim rFind As Range, rDataAll As Range
Dim r As Range, rTarget As Range
Set rFind = Sheets("Edit").Range("D2")
If Sheets("Edit").Range("D2") = "" Then Exit Sub
With Sheets("DataStore")
    Set rDataAll = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
    If .Columns("b:b").Find(rFind, LookIn:=xlValues) Is Nothing Then
        MsgBox "äÁèÁÕàÅ¢·Õè¹Õé!"
        Exit Sub
    End If
End With
For Each r In rDataAll
    If r = rFind Then
        Set rTarget = Sheets("Edit").Range("C" & Rows.Count).End(xlUp) _
            .Offset(1, 0)
        r.Resize(1, 8).Copy
        rTarget.PasteSpecial xlPasteValues
        rTarget.Offset(0, -1) = Date
    End If
Next r
Application.CutCopyMode = False
MsgBox "Get data has finished."
End Sub

Code: Select all

Sub Update()
Dim rsAll As Range, rtAll As Range
Dim rs As Range, i As Integer

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error Resume Next

With Worksheets("Edit")
    Set rsAll = .Range("B4", .Range("B" & Rows.Count).End(xlUp))
End With

With Worksheets("DataStore")
    Set rtAll = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
End With

For Each rs In rsAll
    For i = rtAll.Count To 1 Step -1    
        If rs = rtAll(i) And rs.Offset(0, 8) = rtAll(i).Offset(0, 8) _
        And rs.Offset(0, 9) = "Update" Then
            rs.Offset(0, -1).Resize(1, 10).Copy
            rtAll(i).Offset(0, -1).PasteSpecial xlPasteValues
        End If
    Next i
Next rs

Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub