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 SearchMultipleSheets()
Dim arr(999, 6) As Variant, r As Range
Dim ws As Worksheet, i As Integer, s As String
With Sheets(1)
s = .Range("c1").Value
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
For Each ws In Worksheets
If ws.Name <> Sheets(1).Name Or ws.Name <> Sheets("ตัวอย่างที่ต้องการค่ะ").Name Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Value & r.Offset(0, 1).Value & r.Offset(0, 5).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value & r.Offset(0, 25).Value _
Like "*" & s & "*" Then
arr(i, 0) = r.Value
arr(i, 0) = r.Offset(0, 1).Value
arr(i, 1) = r.Offset(0, 5).Value
arr(i, 2) = r.Offset(0, 7).Value
arr(i, 3) = r.Offset(0, 8).Value
arr(i, 4) = r.Offset(0, 25).Value
arr(i, 5) = ws.Name
i = i + 1
End If
Next r
End With
End If
Next ws
With Sheets(1)
.Range("b3").Resize(i, 7).Value = arr
End With
End Sub
Code: Select all
...Code อื่นๆ ...
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
If r.Value & r.Offset(0, 1).Value & r.Offset(0, 5).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value & r.Offset(0, 25).Value _
Like "*" & s & "*" Then
arr(i, 0) = r.Value
arr(i, 0) = r.Offset(0, 1).Value
arr(i, 1) = r.Offset(0, 5).Value
arr(i, 2) = r.Offset(0, 7).Value
arr(i, 3) = r.Offset(0, 8).Value
arr(i, 4) = r.Offset(0, 25).Value
arr(i, 5) = ws.Name
i = i + 1
End If
End If
Next r
...Code อื่นๆ ...
Code: Select all
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
Code: Select all
Sub SearchMultipleSheets()
Dim arr(999, 6) As Variant, r As Range
Dim ws As Worksheet, i As Integer, s As String
With Sheets(1)
s = .Range("c1").Value
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
For Each ws In Worksheets
If ws.Name <> Sheets(1).Name Or ws.Name <> Sheets("ตัวอย่างที่ต้องการค่ะ").Name Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
If r.Value & r.Offset(0, 1).Value & r.Offset(0, 5).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value & r.Offset(0, 25).Value _
Like "*" & s & "*" Then
arr(i, 0) = r.Value
arr(i, 0) = r.Offset(0, 1).Value
arr(i, 1) = r.Offset(0, 5).Value
arr(i, 2) = r.Offset(0, 7).Value
arr(i, 3) = r.Offset(0, 8).Value
arr(i, 4) = r.Offset(0, 25).Value
arr(i, 5) = ws.Name
i = i + 1
End If
End If
Next r
End With
End If
Next ws
With Sheets(1)
.Range("b3").Resize(i, 7).Value = arr
End With
End Sub
Code: Select all
Sub SearchMultipleSheets()
Dim arr(999, 6) As Variant, r As Range
Dim ws As Worksheet, i As Integer, s As Range
With Sheets(1)
Set s = .Range("c1")
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
For Each ws In Worksheets
If ws.Name = "ดูรายละเอียด" Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 1).Value2 = s.Value2 Then
arr(i, 0) = i
arr(i, 1) = r.Offset(0, 1).Value
arr(i, 2) = r.Offset(0, 5).Value
arr(i, 3) = r.Offset(0, 7).Value
arr(i, 4) = r.Offset(0, 8).Value
arr(i, 5) = r.Offset(0, 25).Value
i = i + 1
End If
Next r
End With
End If
Next ws
With Sheets(1)
If i > 0 Then
.Range("a3").Resize(i, 7).Value = arr
End If
End With
End Sub
น่าแปลกครับ ผมรันได้ปกติดี ลองดูตามไฟล์แนบครับ ผมปรับโค้ดนิดหน่อยตรงการเลือกชีท แต่ไม่ได้ปรับอะไรตรงบรรทัดที่คุณ suka ติดปัญหาเลยครับ บรรทัดนั้นสั่งให้ตรวจเลขบิล โดยหากเป็นเลขบิลเดิมให้ข้ามไปเลย ไม่ต้องเก็บข้อมูลแถวนั้นในตัวแปรอาร์เรย์ครับsuka wrote:ปรับ Code เป็นด้านล่างนี้แล้วเมื่อ Run Code ฟ้องระบายสีเหลืองที่
ไม่ทราบว่าควรปรับแก้อย่างไรดีคะCode: Select all
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
Code: Select all
... code เดิม...
For Each ws In Worksheets
If ws.Name <> Sheets(1).Name And ws.Name <> Sheets(2).Name Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
If r.Value & r.Offset(0, 1).Value & r.Offset(0, 5).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value & r.Offset(0, 25).Value _
Like "*" & s & "*" Then
arr(i, 0) = i + 1
arr(i, 1) = r.Offset(0, 1).Value
arr(i, 2) = r.Offset(0, 5).Value
arr(i, 3) = r.Offset(0, 7).Value
arr(i, 4) = r.Offset(0, 8).Value
arr(i, 5) = r.Offset(0, 25).Value
arr(i, 6) = ws.Name
i = i + 1
End If
End If
Next r
End With
End If
Next ws
... code เดิม ...
Code: Select all
Sub SearchMultipleSheets()
Dim arr(999, 6) As Variant, r As Range
Dim ws As Worksheet, i As Integer, s As Range
With Sheets(1)
Set s = .Range("c1")
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
For Each ws In Worksheets
If ws.Name = "´ÙÃÒÂÅÐàÍÕ´" Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
If r.Offset(0, 1).Value2 = s.Value2 Then
arr(i, 0) = i
arr(i, 1) = r.Offset(0, 1).Value
arr(i, 2) = r.Offset(0, 5).Value
arr(i, 3) = r.Offset(0, 7).Value
arr(i, 4) = r.Offset(0, 8).Value
arr(i, 5) = r.Offset(0, 25).Value
i = i + 1
End If
End If
Next r
End With
End If
Next ws
With Sheets(1)
If i > 0 Then
.Range("a3").Resize(i, 7).Value = arr
End If
End With
End Sub
โค้ดของคุณ DhitiBank ช่วยได้มากเลยค่ะDhitiBank wrote:น่าแปลกครับ ผมรันได้ปกติดี ลองดูตามไฟล์แนบครับ ผมปรับโค้ดนิดหน่อยตรงการเลือกชีท แต่ไม่ได้ปรับอะไรตรงบรรทัดที่คุณ suka ติดปัญหาเลยครับ บรรทัดนั้นสั่งให้ตรวจเลขบิล โดยหากเป็นเลขบิลเดิมให้ข้ามไปเลย ไม่ต้องเก็บข้อมูลแถวนั้นในตัวแปรอาร์เรย์ครับsuka wrote:ปรับ Code เป็นด้านล่างนี้แล้วเมื่อ Run Code ฟ้องระบายสีเหลืองที่
ไม่ทราบว่าควรปรับแก้อย่างไรดีคะCode: Select all
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
Code: Select all
Sub AdvancedFilterInv()
Sheets("กรองข้อมูล").Range("A1:AD20000").ClearContents
Sheets("Database").Columns("A:AD").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("ค้นหา").Range("A2:G3"), CopyToRange:=Sheets("กรองข้อมูล").Range("A1"), Unique:=False
Application.Goto reference:="OFFSET(R1C1,COUNTA(C1),0)"
End Sub
Code: Select all
Sub SearchMultipleSheets()
Dim arr(999, 8) As Variant, r As Range
Dim ws As Worksheet, i As Integer, s As Range
With Sheets("รายงาน")
Set s = Sheets("ค้นหา").Range("a4")
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
For Each ws In Worksheets
If ws.Name = "กรองข้อมูล" Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
If r.Offset(0, 1).Value2 = s.Value2 Then
arr(i, 0) = i
arr(i, 0) = r.Offset(0, 1).Value
arr(i, 1) = r.Offset(0, 5).Value
arr(i, 2) = r.Offset(0, 7).Value
arr(i, 3) = r.Offset(0, 8).Value
arr(i, 5) = r.Offset(0, 24).Value
arr(i, 6) = r.Offset(0, 25).Value
i = i + 1
End If
End If
Next r
End With
End If
Next ws
With Sheets("รายงาน")
If i > 0 Then
.Range("b3").Resize(i, 9).Value = arr
End If
End With
Range("F3:F" & Range("H5000").End(xlUp).Row).Formula = "=IF(H3="""","""",SUM(H3-G3))"
End Sub
Code: Select all
With Sheets("รายงาน")
Set s = Sheets("ค้นหา").Range("a4")
For Each s In Sheets("ค้นหา").Range("a4").Value
If s.Value >= Sheets("ค้นหา").Range("a4").Value Then
s.Value = Sheets("ค้นหา").Range("b4").Value
End If
Next s
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
Code: Select all
Sub SearchMultipleSheets()
Dim arr(999, 8) As Variant, r As Range
Dim ws As Worksheet, i As Integer, s As Range
With Sheets("รายงาน")
Set s = Sheets("ค้นหา").Range("a4")
For Each s In Sheets("ค้นหา").Range("a4").Value
If s.Value >= Sheets("ค้นหา").Range("a4").Value Then
s.Value = Sheets("ค้นหา").Range("b4").Value
End If
Next s
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
For Each ws In Worksheets
If ws.Name = "กรองข้อมูล" Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
If r.Offset(0, 1).Value2 = s.Value2 Then
arr(i, 0) = i
arr(i, 0) = r.Offset(0, 1).Value
arr(i, 1) = r.Offset(0, 5).Value
arr(i, 2) = r.Offset(0, 7).Value
arr(i, 3) = r.Offset(0, 8).Value
arr(i, 5) = r.Offset(0, 24).Value
arr(i, 6) = r.Offset(0, 25).Value
i = i + 1
End If
End If
Next r
End With
End If
Next ws
With Sheets("รายงาน")
If i > 0 Then
.Range("b3").Resize(i, 9).Value = arr
End If
End With
Range("F3:F" & Range("H5000").End(xlUp).Row).Formula = "=IF(H3="""","""",SUM(H3-G3))"
End Sub
For Each s In Sheets("ค้นหา").Range("a4").Value
นั้นเป็น Code ที่ไม่ถูกต้องCode: Select all
Sub SearchMultipleSheets()
Dim arr(999, 8) As Variant, r As Range
Dim ws As Worksheet, i As Integer, s As Range
With Sheets("รายงาน")
Set s = Sheets("ค้นหา").Range("a4:b4")
.Range("b3").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
End With
For Each ws In Worksheets
If ws.Name = "กรองข้อมูล" Then
With ws
For Each r In .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
If r.Offset(0, 1).Value2 = s.Value2 Then
arr(i, 0) = i
arr(i, 0) = r.Offset(0, 1).Value
arr(i, 1) = r.Offset(0, 5).Value
arr(i, 2) = r.Offset(0, 7).Value
arr(i, 3) = r.Offset(0, 8).Value
arr(i, 5) = r.Offset(0, 24).Value
arr(i, 6) = r.Offset(0, 25).Value
i = i + 1
End If
End If
Next r
End With
End If
Next ws
With Sheets("รายงาน")
If i > 0 Then
.Range("b3").Resize(i, 7).Value = arr
End If
End With
Range("F3:F" & Range("H5000").End(xlUp).Row).Formula = "=IF(H3="""","""",SUM(H3-G3))"
End Sub
Code: Select all
If r.Offset(0, 5).Value <> r.Offset(-1, 5).Value Then
'If r.Offset(0, 1).Value2 = s.Value2 Then
If r.Offset(0, 1).Value2 >= s(1).Value2 And r.Offset(0, 1).Value2 <= s(2).Value2 Then
arr(i, 0) = i
arr(i, 0) = r.Offset(0, 1).Value
arr(i, 1) = r.Offset(0, 5).Value
arr(i, 2) = r.Offset(0, 7).Value
arr(i, 3) = r.Offset(0, 8).Value
arr(i, 5) = r.Offset(0, 24).Value
arr(i, 6) = r.Offset(0, 25).Value
i = i + 1
End If
End If
Code: Select all
Range("F3:F" & Range("H5000").End(xlUp).Row).Formula = "=IF(H3="""","""",SUM(H3-G3))"
Range("f3:f" & Range("a5000").End(xlUp).Row).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False