Snasui Excel Forum

Code: Select all

Sub UpdateProduct()
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("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Database")
    Set rtAll = .Range("A1", .Range("A" & 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, 0) = rtAll(i).Offset(0, 0) _
        And rs.Offset(0, 1) <> "" Then
            rs.Offset(0, 1).Copy
            rtAll(i).Offset(0, 1).PasteSpecial xlPasteValues
        End If
        Next i
    Next rs
    
    With Worksheets("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Data")
    Set rtAll = .Range("A1", .Range("A" & 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, 0) = rtAll(i).Offset(0, 0) _
        And rs.Offset(0, 1) <> "" Then
            rs.Offset(0, 1).Copy
            rtAll(i).Offset(0, 1).PasteSpecial xlPasteValues
        End If
        Next i
    Next rs
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("บันทึกข้อมูลเรียบร้อยแล้ว")

End Sub

Code: Select all

Sub UpdateProduct()
    Dim rsAll As Range, rtAll As Range
    Dim rs As Range, rt As Range
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
'    On Error Resume Next
    With Worksheets("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Database")
    Set rtAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each rs In rsAll
        For Each rt In rtAll
            If rs = rt Then
                rt.Offset(0, 1) = rs.Offset(0, 1)
            End If
        Next
    Next rs
    With Worksheets("Product")
        Set rsAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    With Worksheets("Data")
    Set rtAll = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each rs In rsAll
        For Each rt In rtAll
            If rs = rt Then
                rt.Offset(0, 1) = rs.Offset(0, 1)
            End If
        Next rt
    Next rs
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox ("บันทึกข้อมูลเรียบร้อยแล้ว")
End Sub

Code: Select all

Sub Macro1()
    Application.ScreenUpdating = False
    
    '*****Database****
    Range("C1").FormulaR1C1 = "=COUNTIF(Database!R1C1:R2000C1,RC[-2])"
    Range("C1").AutoFill Destination:=Range("C1:C2000")
    Range("A2").CurrentRegion.Select
    ActiveSheet.Range("$a$1:$C$2000").AutoFilter Field:=3, Criteria1:="0"
    Set r = ActiveSheet.AutoFilter.Range
    Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1, 2)
    r.Copy
    Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    '******Data******
    Range("C1").FormulaR1C1 = "=COUNTIF(Data!R1C1:R2000C1,RC[-2])"
    Sheets(1).Range("C1").AutoFill Destination:=Range("C1:C2000")
    Range("A2").CurrentRegion.Select
    ActiveSheet.Range("$a$1:$C$2000").AutoFilter Field:=3, Criteria1:="0"
    Set r = ActiveSheet.AutoFilter.Range
    Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1, 2)
    r.Copy
    Sheets(3).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    
    '****clear data,filter *****
    Selection.AutoFilter
    Application.CutCopyMode = False
    Sheets(1).Range("C1:C2000").ClearContents
    Application.ScreenUpdating = True
End Sub