ดึงข้อมูลวันที่แต่จัดรูปแบบไม่ได้

[Somchai Saisamer]

ผมดึงข้อมูลจาก mainsheet ไปไว้ที่ชีท "ช" โดนกดปุ่ม "Mon" แต่ ผลที่ได้มี่ปัญหาสองอย่างคือ
1.ที่แถว 17 เป็นแถวว่าง
2.รูปแบบวันที่ ที่ชีท "ช" เปลี่ยนไป (บางแถววันที่สลับกับเดือน)
จะแก้ไขได้อย่างไรครับ
Public Sub Moneyupdate()
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 ActiveSheet

Set rAll = .Range("f17", .Range("f" & rl).End(xlUp))

End With

For Each r In rAll
If r = ActiveSheet.Range("m2") Then

lng = lng + 1
ReDim Preserve a(8, lng)
a(0, lng) = lng
a(1, lng) = r.Offset(0, -5)
a(2, lng) = r.Offset(0, -4)
a(3, lng) = r.Offset(0, -3)
a(4, lng) = r.Offset(0, -2)
a(5, lng) = r.Offset(0, -1)
a(6, lng) = r.Offset(0, 0)
a(7, lng) = r.Offset(0, 1)


End If
Next r
If lng > 0 Then
With Worksheets("ช")
.Range("A18", .Range("A" & rl).End(xlDown).Offset(0, 7)).ClearContents
Set rt = .Range("A17", .Range("h" & lng + 17))
rt = Application.Transpose(a)
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[bank9597]

ลองดูครับ
แก้ปัญหารูปแบบวันที่ ไปที่ control panel > language and region > Administrative > change system local แล้วเลือกเป็น thai ครับ

ส่วนตัวโค๊ด ขอรหัสผ่านด้วยครับ เข้าไปทดสอบโค๊ดไม่ได้

[Somchai Saisamer]

ขอโทษครับ ผมลืมไปว่ามีรหัสครับ ผมแนบไฟล์ไม่มีรหัสมาใหม่แล้วนะครับ

[Somchai Saisamer]

ลองดูครับ
แก้ปัญหารูปแบบวันที่ ไปที่ control panel > language and region > Administrative > change system local แล้วเลือกเป็น thai ครับ

ส่วนตัวโค๊ด ขอรหัสผ่านด้วยครับ เข้าไปทดสอบโค๊ดไม่ได้

เข้าไปตั้งค่าตามที่คุณบอกแล้วนะครับ ค่าเดิมก็เป็น thai อยู่ครับ เลยได้ผลเหมือนเดิมครับ

[bank9597]

ขอโทษครับ ผมลืมไปว่ามีรหัสครับ ผมแนบไฟล์ไม่มีรหัสมาใหม่แล้วนะครับ

ลองปรับโค๊ด

Public Sub Moneyupdate()
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 ActiveSheet

Set rAll = .Range("f17", .Range("f" & rl).End(xlUp))

End With

For Each r In rAll
If r = ActiveSheet.Range("m2") Then

lng = lng + 1
ReDim Preserve a(8, lng)
a(0, lng - 1) = lng
a(1, lng - 1) = r.Offset(0, -5)
a(2, lng - 1) = r.Offset(0, -4)
a(3, lng - 1) = r.Offset(0, -3)
a(4, lng - 1) = r.Offset(0, -2)
a(5, lng - 1) = r.Offset(0, -1)
a(6, lng - 1) = r.Offset(0, 0)
a(7, lng - 1) = r.Offset(0, 1)


End If
Next r
If lng > 0 Then
With Worksheets("ª")
.Range("A18", .Range("A" & rl).End(xlDown).Offset(0, 7)).ClearContents
Set rt = .Range("A17", .Range("h" & lng + 17))
rt = Application.Transpose(a)
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[Somchai Saisamer]

ขอโทษครับ ผมลืมไปว่ามีรหัสครับ ผมแนบไฟล์ไม่มีรหัสมาใหม่แล้วนะครับ

ลองปรับโค๊ด

Public Sub Moneyupdate()
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 ActiveSheet

Set rAll = .Range("f17", .Range("f" & rl).End(xlUp))

End With

For Each r In rAll
If r = ActiveSheet.Range("m2") Then

lng = lng + 1
ReDim Preserve a(8, lng)
a(0, lng - 1) = lng
a(1, lng - 1) = r.Offset(0, -5)
a(2, lng - 1) = r.Offset(0, -4)
a(3, lng - 1) = r.Offset(0, -3)
a(4, lng - 1) = r.Offset(0, -2)
a(5, lng - 1) = r.Offset(0, -1)
a(6, lng - 1) = r.Offset(0, 0)
a(7, lng - 1) = r.Offset(0, 1)


End If
Next r
If lng > 0 Then
With Worksheets("ª")
.Range("A18", .Range("A" & rl).End(xlDown).Offset(0, 7)).ClearContents
Set rt = .Range("A17", .Range("h" & lng + 17))
rt = Application.Transpose(a)
End With
Else
MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

ขอบคุณครับ จะลองดูครับ

[Somchai Saisamer]

ทดลองเปลี่ยนโค๊ดตามที่แนะนำแล้วครับ ใช้ได้ผลดี คำตอบตรงตามที่ต้องการ ข้อ1.ครับ ขอบคุณมากครับ
แต่ยังมีปัญหาเรื่อง รูปแบบวันที่ตามข้อ2.รูปแบบวันที่ ที่ชีท "ช" เปลี่ยนไป (บางแถววันที่สลับกับเดือน)

[bank9597]

ทดลองเปลี่ยนโค๊ดตามที่แนะนำแล้วครับ ใช้ได้ผลดี คำตอบตรงตามที่ต้องการ ข้อ1.ครับ ขอบคุณมากครับ
แต่ยังมีปัญหาเรื่อง รูปแบบวันที่ตามข้อ2.รูปแบบวันที่ ที่ชีท "ช" เปลี่ยนไป (บางแถววันที่สลับกับเดือน)

ยังแก้ไม่ได้ครับ เลยปรับโค๊ดใหม่ดังนี้

Code: Select all

Public Sub Moneyupdate()
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim rLast As Integer
    Dim name As String
    Dim i As Integer
    
    Set ws = Sheets("Mainsheet")
    Set ws1 = Sheets("ª")
    
    ws1.Range("A17:G100").ClearContents
    name = ws.Range("M2").Value
    rLast = ws.Range("A100").End(xlUp).Row
    
    For i = 17 To rLast
        If ws.Cells(i, 6) = name Then
            ws.Range(Cells(i, 1), Cells(i, 7)).Copy
            ws1.Range("B100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            
    
    End If
    Next i
end if

[Somchai Saisamer]

ทดลองเปลี่ยนโค๊ดตามที่แนะนำแล้วครับ ใช้ได้ผลดี คำตอบตรงตามที่ต้องการ ข้อ1.ครับ ขอบคุณมากครับ
แต่ยังมีปัญหาเรื่อง รูปแบบวันที่ตามข้อ2.รูปแบบวันที่ ที่ชีท "ช" เปลี่ยนไป (บางแถววันที่สลับกับเดือน)

ยังแก้ไม่ได้ครับ เลยปรับโค๊ดใหม่ดังนี้

Code: Select all

Public Sub Moneyupdate()
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim rLast As Integer
    Dim name As String
    Dim i As Integer
    
    Set ws = Sheets("Mainsheet")
    Set ws1 = Sheets("ª")
    
    ws1.Range("A17:G100").ClearContents
    name = ws.Range("M2").Value
    rLast = ws.Range("A100").End(xlUp).Row
    
    For i = 17 To rLast
        If ws.Cells(i, 6) = name Then
            ws.Range(Cells(i, 1), Cells(i, 7)).Copy
            ws1.Range("B100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            
    
    End If
    Next i
end if

ใช้ได้แล้วครับตรงตามความต้องการ ขอบคุณมากครับที่กรุณาแนะนำ

[Somchai Saisamer]

ทดลองเปลี่ยนโค๊ดตามที่แนะนำแล้วครับ ใช้ได้ผลดี คำตอบตรงตามที่ต้องการ ข้อ1.ครับ ขอบคุณมากครับ
แต่ยังมีปัญหาเรื่อง รูปแบบวันที่ตามข้อ2.รูปแบบวันที่ ที่ชีท "ช" เปลี่ยนไป (บางแถววันที่สลับกับเดือน)

ยังแก้ไม่ได้ครับ เลยปรับโค๊ดใหม่ดังนี้

Code: Select all

Public Sub Moneyupdate()
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim rLast As Integer
    Dim name As String
    Dim i As Integer
    
    Set ws = Sheets("Mainsheet")
    Set ws1 = Sheets("ª")
    
    ws1.Range("A17:G100").ClearContents
    name = ws.Range("M2").Value
    rLast = ws.Range("A100").End(xlUp).Row
    
    For i = 17 To rLast
        If ws.Cells(i, 6) = name Then
            ws.Range(Cells(i, 1), Cells(i, 7)).Copy
            ws1.Range("B100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            
    
    End If
    Next i
end if

ขอโทษครับ มีปัญหาเพิ่ม มาครับ คือถ้ามีข้อมูลเยอะๆ ใช้ code ข้างบน จะช้ามากครับ พอแนะนำวิธีแก้ไขได้ไหมครับ

[bank9597]

ทดลองเปลี่ยนโค๊ดตามที่แนะนำแล้วครับ ใช้ได้ผลดี คำตอบตรงตามที่ต้องการ ข้อ1.ครับ ขอบคุณมากครับ
แต่ยังมีปัญหาเรื่อง รูปแบบวันที่ตามข้อ2.รูปแบบวันที่ ที่ชีท "ช" เปลี่ยนไป (บางแถววันที่สลับกับเดือน)

ยังแก้ไม่ได้ครับ เลยปรับโค๊ดใหม่ดังนี้

Code: Select all

Public Sub Moneyupdate()
    Dim ws As Worksheet
    Dim ws1 As Worksheet
    Dim rLast As Integer
    Dim name As String
    Dim i As Integer
    
    Set ws = Sheets("Mainsheet")
    Set ws1 = Sheets("ª")
    
    ws1.Range("A17:G100").ClearContents
    name = ws.Range("M2").Value
    rLast = ws.Range("A100").End(xlUp).Row
    
    For i = 17 To rLast
        If ws.Cells(i, 6) = name Then
            ws.Range(Cells(i, 1), Cells(i, 7)).Copy
            ws1.Range("B100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            
    
    End If
    Next i
end if

ขอโทษครับ มีปัญหาเพิ่ม มาครับ คือถ้ามีข้อมูลเยอะๆ ใช้ code ข้างบน จะช้ามากครับ พอแนะนำวิธีแก้ไขได้ไหมครับ

ตอนนี้ผมคิดได้แค่นี้จริงๆครับ

เดี๋ยวรอท่านอื่นมาเพิ่มให้อีกครั้งน่ะครับ สู้ๆ

[snasui]

ลองเพิ่มการยกเลิกการ Update Screen เข้าไปช่วยครับ

Code: Select all

'Other code
Application.ScreenUpdating = False
    For i = 17 To rLast
        If ws.Cells(i, 6) = name Then
            ws.Range(Cells(i, 1), Cells(i, 7)).Copy
            ws1.Range("B100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    Next i
Application.ScreenUpdating = True
'Other code

[Somchai Saisamer]

ลองเพิ่มการยกเลิกการ Update Screen เข้าไปช่วยครับ

Code: Select all

'Other code
Application.ScreenUpdating = False
    For i = 17 To rLast
        If ws.Cells(i, 6) = name Then
            ws.Range(Cells(i, 1), Cells(i, 7)).Copy
            ws1.Range("B100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    Next i
Application.ScreenUpdating = True
'Other code

ขอบคุณครับ จะลองดูครับ

[Somchai Saisamer]

ลองเพิ่มการยกเลิกการ Update Screen เข้าไปช่วยครับ

Code: Select all

'Other code
Application.ScreenUpdating = False
    For i = 17 To rLast
        If ws.Cells(i, 6) = name Then
            ws.Range(Cells(i, 1), Cells(i, 7)).Copy
            ws1.Range("B100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    Next i
Application.ScreenUpdating = True
'Other code

ทดลองแล้ว ใช้ได้ครับ เร็วขึ้น คำตอบตรงตามต้องการครับ ขอบคุณครับ