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]
เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)yodpao.b wrote:ทำตามตัวอย่างลิงค์http://snasui.blogspot.com/2011/06/vba_26.html ที่อาจาร์ยให้มา
Code: Select all
Option Explicit
Option Base 1
Sub ShowEmp()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("Database")
Set rAll = .Range("F2", .Range("F" & rl).End(xlUp))
End With
For Each r In rAll
If r = Worksheets("Report").Range("E2") Then
lng = lng + 1
ReDim Preserve a(5, lng)
a(1, lng) = lng
a(2, lng) = r.Offset(0, -5)
a(3, lng) = r.Offset(0, -4)
a(4, lng) = r.Offset(0, -3)
a(5, lng) = r.Offset(0, -2)
End If
Next r
If lng > 0 Then
With Worksheets("Report")
Set rt = .Range("A5", .Range("E" & lng - 1 + 5))
If .Range("A5") <> "" Then 'Check if isblank
.Range("A5", .Range("A" & rl).End(xlUp).Offset(0, 4)).ClearContents
End If
.Range("A5:E5").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
.Range("B5", .Range("B" & rl).End(xlUp)).NumberFormat = "000000"
.Range(.Range("A4").End(xlDown).Offset(1, 0), .Range("E" & rl)).Clear 'Change new start cell
.Range("E2").Activate
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Code: Select all
Option Explicit
Option Base 1
Sub ShowEmp()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("ฐานข้อมูลล่วงเวลา")
Set rAll = .Range("B7", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
If r = Worksheets("Report").Range("F3") Then
lng = lng + 1
ReDim Preserve a(13, lng)
a(1, lng) = r.Offset(0, 11)
a(2, lng) = r.Offset(0, 4)
a(3, lng) = r.Offset(0, 6)
a(4, lng) = r.Offset(0, 7)
a(5, lng) = r.Offset(0, 13)
a(6, lng) = r.Offset(0, 14)
a(7, lng) = r.Offset(0, 15)
a(8, lng) = r.Offset(0, 16)
a(9, lng) = r.Offset(0, 17)
a(10, lng) = r.Offset(0, 18)
a(11, lng) = r.Offset(0, 19)
a(12, lng) = r.Offset(0, 20)
'a(13, lng) = r.Offset(0, 22)
End If
Next r
If lng > 0 Then
With Worksheets("Report")
Set rt = .Range("C11", .Range("N" & lng - 1 + 11))
If .Range("C11") <> "" Then 'Check if isblank
.Range("C11", .Range("C" & rl).End(xlUp).Offset(0, 12)).ClearContents
End If
.Range("C11:N11").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
'.Range("B5", .Range("B" & rl).End(xlUp)).NumberFormat = "000000"
.Range(.Range("C10").End(xlDown).Offset(1, 0), .Range("N" & rl)).Clear 'Change new start cell
' .Range("F3").Select
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Code: Select all
Application.EnableEvents = False
Application.ScreenUpdating = False
Code: Select all
rl = Rows.Count
With Worksheets("°Ò¹¢éÍÁÙÅÅèǧàÇÅÒ")
Set rAll = .Range("B7", .Range("B" & rl).End(xlUp))
End Wit
Code: Select all
For Each r In rAll
If r = Worksheets("Report").Range("F3") Then
lng = lng + 1
ReDim Preserve a(13, lng)
a(1, lng) = r.Offset(0, 11)
a(11, lng) = r.Offset(0, 19)
a(12, lng) = r.Offset(0, 20)
End If
Code: Select all
Next r
If lng > 0 Then
With Worksheets("Report")
Set rt = .Range("C11", .Range("N" & lng - 1 + 11))
If .Range("C11") <> "" Then 'Check if isblank
.Range("C11", .Range("C" & rl).End(xlUp).Offset(0, 12)).ClearContents
End If
Code: Select all
.Range("C11:N11").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
.Range(.Range("C10").End(xlDown).Offset(1, 0), .Range("N" & rl)).Clear
Code: Select all
Application.EnableEvents = False
Code: Select all
Application.ScreenUpdating = False
Code: Select all
rl = Rows.Count
Code: Select all
With Worksheets("ฐานข้อมูลล่วงเวลา")
Set rAll = .Range("B7", .Range("B" & rl).End(xlUp))
End With
Code: Select all
For Each r In rAll
If r = Worksheets("Report").Range("F3") Then
lng = lng + 1
ReDim Preserve a(13, lng)
a(1, lng) = r.Offset(0, 11)
a(2, lng) = r.Offset(0, 4)
a(3, lng) = r.Offset(0, 6)
a(4, lng) = r.Offset(0, 7)
a(5, lng) = r.Offset(0, 13)
a(6, lng) = r.Offset(0, 14)
a(7, lng) = r.Offset(0, 15)
a(8, lng) = r.Offset(0, 16)
a(9, lng) = r.Offset(0, 17)
a(10, lng) = r.Offset(0, 18)
a(11, lng) = r.Offset(0, 19)
a(12, lng) = r.Offset(0, 20)
'a(13, lng) = r.Offset(0, 22)
End If
Next r
Code: Select all
If lng > 0 Then
With Worksheets("Report")
Set rt = .Range("C11", .Range("N" & lng - 1 + 11))
If .Range("C11") <> "" Then 'Check if isblank
.Range("C11", .Range("C" & rl).End(xlUp).Offset(0, 12)).ClearContents
End If
.Range("C11:N11").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
'.Range("B5", .Range("B" & rl).End(xlUp)).NumberFormat = "000000"
.Range(.Range("C10").End(xlDown).Offset(1, 0), .Range("N" & rl)).Clear 'Change new start cell
' .Range("F3").Select
End With
Else
MsgBox "Data not found."
End If
Code: Select all
With Worksheets("Report")
Set rt = .Range("C11", .Range("N" & lng - 1 + 11))
If .Range("C11") <> "" Then 'Check if isblank
.Range("C11", .Range("C" & rl).End(xlUp).Offset(0, 12)).ClearContents
End If
.Range("C11:N11").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
'.Range("B5", .Range("B" & rl).End(xlUp)).NumberFormat = "000000"
.Range(.Range("C10").End(xlDown).Offset(1, 0), .Range("N" & rl)).Clear 'Change new start cell
' .Range("F3").Select
End With
Code: Select all
Option Explicit
Option Base 1
Sub ShowEmp()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("ฐานข้อมูลล่วงเวลา")
Set rAll = .Range("B7", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
If r = Worksheets("Report").Range("F3") Then
lng = lng + 1
ReDim Preserve a(13, lng)
a(1, lng) = r.Offset(0, 11)
a(2, lng) = r.Offset(0, 4)
a(3, lng) = r.Offset(0, 6)
a(4, lng) = r.Offset(0, 7)
a(5, lng) = r.Offset(0, 13)
a(6, lng) = r.Offset(0, 14)
a(7, lng) = r.Offset(0, 15)
a(8, lng) = r.Offset(0, 16)
a(9, lng) = r.Offset(0, 17)
a(10, lng) = r.Offset(0, 18)
a(11, lng) = r.Offset(0, 19)
a(12, lng) = r.Offset(0, 20)
'a(13, lng) = r.Offset(0, 22)
End If
Next r
If lng > 0 Then
With Worksheets("Report")
Set rt = .Range("C11", .Range("N" & lng - 1 + 11))
If .Range("C11") <> "" Then 'Check if isblank
.Range("C11", .Range("C" & rl).End(xlUp).Offset(0, 12)).ClearContents
End If
.Range("C11:N11").Copy
rt.PasteSpecial xlPasteFormats
rt = Application.Transpose(a)
'.Range("B5", .Range("B" & rl).End(xlUp)).NumberFormat = "000000"
.Range(.Range("C10").End(xlDown).Offset(1, 0), .Range("N" & rl)).Clear 'Change new start cell
' .Range("F3").Select
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Code: Select all
If r = Worksheets("Report").Range("F3") Then
Code: Select all
If r = Worksheets("Report").Range("F3") and r.offset(0,100) = Worksheets("Report").Range("F1000") Then
Code: Select all
If r = Worksheets("Report").Range("F3") and r.offset(0,100) = Worksheets("Report").Range("F1000") Then
ไม่ใช่ครับyodpao.b wrote:code นี้เกี่ยวกับเดือนเหรอครับ
ควรจะเป็นเช่นนั้นครับyodpao.b wrote:ลอง run แล้วไม่มีอะไรเกิดขึ้น