EXCEL TOOLS
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
Excel Add-ins ที่พัฒนาโดยคุณสันติพงศ์ ณสุย (MVP Excel 2010-2020) ด้วยภาษา C# เพื่อแก้ไขปัญหาไฟล์ใหญ่ คำนวณนาน ทำงานช้า จัดการข้อมูลต่าง ๆ ที่ทำงานประจำวันได้อย่างสะดวกรวดเร็ว สนใจคลิกไปดูได้ที่นี่ครับ => Excel Tools
[code]
และปิดด้วย [/code]
ตัวอย่างเช่น [code]dim r as range[/code]
เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)Code: Select all
Sub Button1_Click()
Sheets("การเบิก").Range("A3:H1000").Copy Sheets("การรับ").Range("A3")
End Sub
Code: Select all
Sub Button1_Click()
Dim rAll As Range, r As Range
With Sheets("การเบิก")
Set rAll = .Range("h3", .Range("h" & .Rows.Count).End(xlUp))
For Each r In rAll
If InStr(r, "รับแล้ว") Then
r.Offset(0, -7).Resize(1, 8).Copy
With .Application.Sheets("การรับ")
.Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End If
Next r
End With
End Sub
ถ้าให้เอาเฉพาะข้อมูลใหม่ ไม่เอาข้อมูลที่ซ้ำกัน ต้องแก้ไขแบบไหนค่ะpuriwutpokin wrote:ปรับเป็นตามนี้ครับCode: Select all
Sub Button1_Click() Dim rAll As Range, r As Range With Sheets("การเบิก") Set rAll = .Range("h3", .Range("h" & .Rows.Count).End(xlUp)) For Each r In rAll If InStr(r, "รับแล้ว") Then r.Offset(0, -7).Resize(1, 8).Copy With .Application.Sheets("การรับ") .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues Application.CutCopyMode = False End With End If Next r End With End Sub
puriwutpokin wrote:ลองแนบไฟล์ตัวอย่าง พร้อมโค้ดมาดูครับ เพื่อนๆสมาชิกจะได้ทดสอบให้ครับ
Code: Select all
Sub Button14_Click()
Dim rAll As Range, r As Range
With Sheets("การเบิก")
Set rAll = .Range("h3", .Range("h" & .Rows.Count).End(xlUp))
For Each r In rAll
If InStr(r, "ได้รับแล้ว") Then
r.Offset(0, -7).Resize(1, 8).Copy
With .Application.Sheets("การรับ")
.Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End If
Next r
End With
End Sub
Code: Select all
With Sheets("การเบิก")
Set rAll = .Range("h3", .Range("h" & .Rows.Count).End(xlUp))
For Each r In rAll
If InStr(r, "รับแล้ว") And Application.CountIfs( _
Worksheets("การรับ").Range("a3:a" & Rows.Count), r.Offset(0, -7).Value, _
Worksheets("การรับ").Range("b3:b" & Rows.Count), r.Offset(0, -6).Value) = 0 Then
r.Offset(0, -7).Resize(1, 8).Copy
With .Application.Sheets("การรับ")
.Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End If
Next r
End With
Code: Select all
Sub Button1_Click()
Application.ScreenUpdating = False
With Sheets("การเบิก")
Set rAll = .Range("h3", .Range("h" & .Rows.Count).End(xlUp))
For Each r In rAll
If InStr(r, "รับแล้ว") And Application.CountIfs( _
Worksheets("การรับ").Range("a3:a" & Rows.Count), r.Offset(0, -7).Value, _
Worksheets("การรับ").Range("b3:b" & Rows.Count), r.Offset(0, -6).Value) = 0 Then
r.Offset(0, -7).Resize(1, 8).Copy
With .Application.Sheets("การรับ")
.Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
r.Offset(0, -7).Resize(1, 8).Delete Shift:=xlUp
End If
Next r
End With
Application.ScreenUpdating = True
End Sub
มีวิธีการลบอย่างไร เป็นการลบด้วยมือหรือลบด้วย Code หากลบด้วย Code ช่วยแนบ Code ที่ได้เขียนสำหรับการลบข้อมูลมาด้วยครับBenmore wrote:ขอสอบถามเพิ่มเติมค่ะ
ถ้าต้องการลบข้อมูลในชีทการเบิก แล้วให้ข้อมูลในชีทการรับลบไปด้วยต้องเพิ่มโค้ดตรงไหนค่ะ
Code: Select all
Sub Button1_Click()
Application.ScreenUpdating = False
With Sheets("การเบิก")
Set rAll = .Range("h3", .Range("h" & .Rows.Count).End(xlUp))
For Each r In rAll
If InStr(r, "รับแล้ว") And Application.CountIfs( _
Worksheets("การรับ").Range("a3:a" & Rows.Count), r.Offset(0, -7).Value, _
Worksheets("การรับ").Range("b3:b" & Rows.Count), r.Offset(0, -6).Value) = 0 Then
r.Offset(0, -7).Resize(1, 8).Copy
With .Application.Sheets("การรับ")
.Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
r.Offset(0, -7).Resize(1, 8).Delete Shift:=xlUp
End If
Next r
End With
Application.ScreenUpdating = True
End Sub
Code: Select all
Sub Button1_Click()
Application.ScreenUpdating = False
Dim i As Long
With Sheets("การเบิก")
For i = 100 To 1 Step -1
If .Range("h" & i).Value = "รับแล้ว" And Application.CountIfs( _
Worksheets("การรับ").Range("a3:a" & Rows.Count), .Range("h" & i).Offset(0, -7).Value, _
Worksheets("การรับ").Range("b3:b" & Rows.Count), .Range("h" & i).Offset(0, -6).Value) > 0 Then
.Range("h" & i).Offset(0, -7).Resize(1, 8).Delete Shift:=xlUp
End If
Next i
With Sheets("การรับ")
.Range("a3:h" & Application.CountIf(.Range("a3:a" & .Rows.Count), "<>") + 2).ClearContents
End With
For i = 1 To 100
If .Range("h" & i).Value = "รับแล้ว" Then
.Range("h" & i).Offset(0, -7).Resize(1, 8).Copy
With .Application.Sheets("การรับ")
.Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End If
Next i
End With
End Sub