Snasui Excel Forum

Code: Select all

Sub sandorder()
 Dim wb As Variant
    Dim source As Range
    Application.ScreenUpdating = False
    Set sourceWb = ThisWorkbook
    Set source = sourceWb.Sheets("Sheet1").Range("W1")
    Set wb = Workbooks.Open("F:\DB\Production Control.xlsx", False, False)
    i = wb.Worksheets("Dataromming").Range("B2:B6000").Find(source, LookIn:=xlValues).Row
    source.Offset(0, 1).Copy
    wb.Worksheets("Dataromming").Range("T" & i).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    wb.Close True
    Sheets("Sheet1").Unprotect ("410036")
    If Worksheets("Sheet2").Range("A12:A33").Find(Range("B9"), LookIn:=xlValues) Is Nothing Then
MsgBox "กรุณาตรวจสอบรายการอีกครั้ง!"
Else
 Sheets("Sheet2").Unprotect ("410036")
i = Worksheets("Sheet2").Range("A12:A39").Find(Range("B9"), LookIn:=xlValues).Row
Worksheets("Sheet1").Range("N5:T5").Copy
Worksheets("Sheet2").Range("B" & i).PasteSpecial xlPasteValues, Transpose:=False
Application.CutCopyMode = True
Sheets("Sheet2").Protect ("410036")
i = Worksheets("Sheet1").Range("A12:A400").Find(Range("B6"), LookIn:=xlValues).Row
Worksheets("Sheet1").Rows(i).Delete
Range("B6,B9").ClearContents
Sheets("Sheet1").Protect ("410036")
Dim msheet
 msheet = ActiveSheet.Name
  With Worksheets(msheet)
      .Protect password:="410036", DrawingObjects:=True, _
       contents:=True, Scenarios:=True, _
       userinterfaceonly:=True
      .EnableAutoFilter = True
    End With
MsgBox "ทำรายการเรียบร้อยแล้ว"
End If
End Sub

Code: Select all

Sub sandorder()
        Dim SourceWb As Workbook
        Dim Wb As Workbook
        Dim rTarget As Range
        Dim rSource As Range
        Dim rRange As Range
        Dim tRange As Range
        Dim tSource As Range
        Dim lngCount As Long
        Dim lngLastRow As Long
        
        Application.ScreenUpdating = False
        
        Set SourceWb = ThisWorkbook
        Set rTarget = SourceWb.Sheets("Sheet1").Range("W1")
        Workbooks.Open ("C:\Users\bank9597\Downloads\Production Control.xlsx")
        
        Set Wb = Workbooks("Production Control.xlsx")
        lngCount = Wb.Sheets("Dataromming").Range("B" & Rows.Count).End(xlUp).Row
        Set rSource = Wb.Sheets("Dataromming").Range("B2:B" & lngCount)
        
        For Each rRange In rSource

            If rRange = rTarget Then
                rRange.Offset(0, 18) = rTarget.Offset(0, 1)
            End If

        Next rRange
        Wb.Close True
        
        Set rSource = Nothing
        Set rRange = Nothing
        Set rTarget = Nothing
        
        Set rTarget = SourceWb.Sheets("Sheet1").Range("B9")
        lngCount = SourceWb.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
        Set rSource = SourceWb.Sheets(1).Range("B12:B" & lngCount)
        
        For Each rRange In rSource
            
            If rRange = rTarget Then
                lngLastRow = SourceWb.Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
                Set tSource = SourceWb.Sheets(2).Range("A12:A" & lngLastRow)
                For Each tRange In tSource
                    If tRange = rTarget Then
                        tRange.Offset(0, 1) = rRange.Offset(0, -1)
                        tRange.Offset(0, 2) = rRange.Offset(0, 2)
                        tRange.Offset(0, 3) = rRange.Offset(0, 4)
                        tRange.Offset(0, 4) = rRange.Offset(0, 5)
                        tRange.Offset(0, 5) = rRange.Offset(0, 6)
                        tRange.Offset(0, 6) = rRange.Offset(0, 9)
                        tRange.Offset(0, 7) = Now()
                    End If
                Next tRange
                rRange.EntireRow.Delete
            End If
            
        Next rRange
        
        MsgBox "·Ó¡ÒÃÊÑè§ÂéÍÁàÃÕºÃéÍÂáÅéÇ"
        Set rSource = Nothing
        Set rRange = Nothing
        Set rTarget = Nothing
        Set tSource = Nothing
        Set tRange = Nothing
        Set Wb = Nothing
        Set SourceWb = Nothing
        
End Sub