snasui.com ยินดีต้อนรับ ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ ระบุ Version ของ Excel
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
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
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
เล่าสู่กันฟังหน่อยได้ไหมครับ ว่าในงานมีอะไรบ้าง