แนะนำการเขียน code VB การในข้อมูลมาใส่ตารางที่มี

[p_d]

เรียน admin,

รบกวนสอบถามค่ะ คือต้องการเขียน code แต่ไม่รู้จะเริ่มอย่างไร ตามข้อมูลตัวอย่างขออธิบายดังนี้ค่ะ
-Sheet Data คือ ข้อมูลที่เรามีอยู่โดยเราต้องการนำ Part code, Posting Date(D) และ Del date(R) ไปใส่ในตารางในชีท Schedule
-Sheet Schedule คือ ตารางที่เราออกแบบเพื่อเก็บข้อมูล โดยระบุ ว่า part code แต่ละตัวมาการสั่งซื้อและจัดส่งวันใดบ้าง ตามตัวอย่างในชีท Schedule ทำแบบ manual ค่ะ ดิฉันไม่เคยทำข้อมูลแบบต้องวนลูปแบบนี้มาก่อนจึงรบกวนแนะนำด้วยค่ะ

ขอบคุณค่ะ
p_d

[snasui]

การใช้งาน VBA ต้องเขียนมาเองก่อนตามกฎการใช้บอร์ดข้อ 5 ด้านบน หากยังไม่มีความรู้เกียวกับกับการเขียนโปรแกรมให้ศึกษามาก่อนตามลำดับ ผมจะเน้นตอบเฉพาะที่เป็นปัญหาเท่านั้นครับ

[p_d]

คุณ snasui

ขอโทษค่ะที่ผิดกฎ ดิฉันได้ลองค้นหา code และนำมาประยุกต์ใช้กับงานนี้ แต่ผลที่ได้คือ ถ้าตรงกับวันที่ใดมันก็จะใส่ให้กับทุก part code เลยค่ะ
รบกวนช่วยดู code ตามนี้ค่ะ

Code: Select all

Sub CopyPartCode()
    Dim nvalue As Long
    Application.ScreenUpdating = False
    Range("A1").Select
    nrow = 4
    Do Until ActiveCell.Offset(1, 0).Value = ""
            With ActiveCell
                    If Len(ActiveCell.Value) = 13 Then
                            Sheets("schedule").Cells(nrow, 1).Value = .Value
                            Set arange = Range(ActiveCell.Offset(1, 6), ActiveCell.Offset(1, 6).End(xlDown))
                            For Each a In arange
                                    tvalue = Left(a.Value, 2)
                                    If tvalue = "" Then Exit For
                                    nvalue = Left(a.Value, 2)
                                    For Each b In Sheets("schedule").Range("c2:ag2")
                                            If nvalue = b.Value Then
                                                Sheets("schedule").Cells(nrow, nvalue + 2).Value = "D"
                                                Exit For
                                            End If
                                    Next b
                            Next a
                            ActiveCell.Offset(1, 0).Select
                            nrow = nrow + 1
                        Else
                            ActiveCell.Offset(1, 0).Select
                    End If
            End With
    Loop
     MsgBox ("Process Completed!")
     Sheets("schedule").Select
End Sub

[snasui]

แนบ Code มาในไฟล์ด้วยจะได้ช่วยทดสอบให้ได้ ไฟล์ที่จะแนบ Code ได้ต้องมีนามสกุลเป็น .xlsm เป็นอย่างน้อยครับ

[p_d]

เรียนคุณ snasui

แนบไฟล์ใหม่ให้แล้วค่ะ รบกวนแนะนำด้วยค่ะ

ขอบคุณค่ะ
p_d

[snasui]

จากไฟล์ที่แนบมาล่าสุดช่วยเติมข้อมูลในชีต Shedule ด้วยว่าต้องการให้เซลล์ใดเป็นเท่าใด พิจารณาอย่างไรจึงเป็นค่านั้น จะได้สะดวกในการทำความเข้าใจครับ

[p_d]

เรียน คุณ snasui
แนบไฟล์คำตอบที่ต้องการมาให้แล้วค่ะ
ขอบคุณค่ะ
p_d

[snasui]

ตัวอย่าง Code ตามด้านล่างครับ

Code: Select all

Sub CopyPartCode()
    Dim nvalue As Integer
    Dim arange As Range
    Dim r As Range
    Dim tvalue As Integer
    Application.ScreenUpdating = False
    nrow = 4
    With Sheets("data")
        Set arange = .Range("a2", .Range("a" & .Rows.Count).End(xlUp)).Offset(0, 6)
    End With
    For Each r In arange
            If Len(r.Offset(0, -6).Value) = 13 Then
                    Sheets("schedule").Cells(nrow, 1).Value = r.Offset(0, -6).Value
                    For Each a In arange
                            tvalue = Left(a.Value, 2)
                            If IsEmpty(tvalue) Then Exit For
                            nvalue = Left(a.Offset(0, -1).Value, 2)
                            For Each b In Sheets("schedule").Range("c2:ag2")
                                    If tvalue = b.Value Then
                                        Sheets("schedule").Cells(nrow, b.Column).Value = "D"
                                    ElseIf nvalue = b.Value Then
                                        Sheets("schedule").Cells(nrow, b.Column).Value = "R"
                                    End If
                            Next b
                    Next a
                    nrow = nrow + 1
            End If
    Next r
    Application.ScreenUpdating = True
     MsgBox ("Process Completed!")
     Sheets("schedule").Select
End Sub

[p_d]

เรียน คุณ snasui
หลังจากรันมาโครแล้วผลลัพธ์ยังไม่ถูกต้องนะคะ ทำไมมันถึงมี R และ D ซ้ำกันหลายครั้งใน part code เดียวกัน ซึ่งจริง ๆ แล้วต้องมีแค่อย่างละ 1 ตัวค่ะ จากตารางข้อมูลตัวอย่าง
เช่น CBDGD0002QS24 ก็จะแสดงค่า R ในช่องวันที่ 17 และ D ในช่องวันที่ 11 เท่านั้น แต่โค้ดที่อาจารย์ให้มารันแล้วพบว่า มี R และ D ในทุกช่องที่อยู่ในช่วงวันที่ของข้อมูลในชีท Data ควรแก้ไขให้ถูกต้องอย่างไรคะ

รบกวนด้วยค่ะ
ขอบคุณค่ะ
p_d

[p_d]

เรียน คุณ snasui

เพื่อให้เห็นภาพผลลัพธ์ที่ต้องการดิฉันแนบไฟล์มาให้อีกครั้งค่ะ รบกวนด้วยนะคะ(ชีท Ex.result) เพราะ part code เยอะมาต้องมานั่ง manual ใส่ตารางช้าละตาลายมากค่ะ

ขอบคุณค่ะ
p_d

[snasui]

ผมลืมแก้ไขตัวแปร a เป็น r ไปสองบรรทัด ตัวอย่าง Code เฉพาะที่ต้องแก้ไขครับ

Code: Select all

'Other code
tvalue = Left(r.Value, 2)
If IsEmpty(tvalue) Then Exit For
nvalue = Left(r.Offset(0, -1).Value, 2)
'Other code

[p_d]

เรียน คุณ snasui
ใช้งานได้ถูกต้องแล้วค่ะ ขอบคุณมากเลยนะคะ แต่ขอสอบถามเพิ่มเติมค่ะ กรณีที่มีข้อมูลมาก ๆ หลายพันแถว ปรากฎว่ามันขึ้น not responding แล้วค้างนานมาก จึงปิดโปรแกรมไป (น่าจะเกิดจากข้อมูลที่วนลูปมาก ๆ ) จึงทดสอบรันประมาณ 500 แถว ก็รอประมาณ 2-3 นาที แบบนี้พอจะมีวิธีแก้ไขไหมคะ

ขอบคุณค่ะ
p_d

[p_d]

ลืมแนบไฟล์ตัวอย่างค่ะ

ขอบคุณค่ะ
p_d

[niwat2811]

Code: Select all

Sub test()
Dim lr As Long, r As Range
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
With Sheets("Data")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("H1").Value = "R"
    .Range("I1").Value = "D"
    For Each r In .Range("F2:F" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    For Each r In .Range("G2:G" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    .Range("A2:A" & lr).Copy Sheets("Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .Range("H1:I" & lr).Copy Sheets("Schedule").Range("AH3")
    .Columns("H:I").ClearContents
End With
lr = Range("A" & Rows.Count).End(xlUp).Row
lc = Cells(3, Columns.Count).End(xlToLeft).Column - 2
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 34) = Cells(2, j) Then
            Cells(i, j).Value = "R"
        End If
    Next j
Next i
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 35) = Cells(2, j) Then
            Cells(i, j).Value = "D"
        End If
    Next j
Next i
Columns("AH:AI").ClearContents
Application.ScreenUpdating = True
End Sub

ลองแบบนี้ดูว่าได้ตามต้องการไหมครับ

[p_d]

เรียน คุณ niwat2811

ขอบคุณสำหรับ code ที่ให้มาค่ะ แต่ยังไม่ตรงตามวัตถุประสงค์ที่จะใช้งาน เพราะต้องการใส่ในรูปแบบ schedule เพื่อง่ายต่อการมองช่วงเวลาระยะห่างทั้ง 2 ตัวแปรนี้ ถ้ารันตามโค้ดที่คุณ niwat2811 จะได้ผลลัพธ์เหมือนการใช้ Text to column ค่ะ

ขอบคุณค่ะ
p_d

[niwat2811]

คงหมายถึง Run Code จากชีท Data ลองแบบนี้ดูครับ

Code: Select all

Sub test()
Dim lr As Long, r As Range
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
With Sheets("Data")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("H1").Value = "R"
    .Range("I1").Value = "D"
    For Each r In .Range("F2:F" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    For Each r In .Range("G2:G" & lr)
        If r.Value <> "" Then
            r.Offset(0, 2).Value = Left(r, 2)
        End If
    Next r
    .Range("A2:A" & lr).Copy Sheets("Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .Range("H1:I" & lr).Copy Sheets("Schedule").Range("AH3")
    .Columns("H:I").ClearContents
End With
Sheets("schedule").Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
lc = Cells(3, Columns.Count).End(xlToLeft).Column - 2
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 34) = Cells(2, j) Then
            Cells(i, j).Value = "R"
        End If
    Next j
Next i
For i = 4 To lr
    For j = 3 To lc
        If Cells(i, 35) = Cells(2, j) Then
            Cells(i, j).Value = "D"
        End If
    Next j
Next i
Columns("AH:AI").ClearContents
Application.ScreenUpdating = True
End Sub

[p_d]

เรียนคุณ niwat2811

ถูกต้องเลยค่ะ รันเร็วมาก ขอบคุณสำหรับความรู้เรื่อง Code VB ยอมแพ้เรื่อง Next , Loop จริง ๆ ค่ะ งงไปหมด (T T)

ขอบคุณมาก ๆ ค่ะ
p_d

[p_d]

รบกวนอีกรอบนะคะ ถ้าเราต้องการเพิ่มเงื่อนไข โดยให้ part code ซ้ำกันรวมเป็นแถวเดียว โดยมีเงื่อนไขดังนี้
1.ถ้าได้รับงานก่อนวัน Del date (หรือวันที่เดียวกัน) จะแสดงผลเป็น R/D ในช่องวัน Del date
2.ถ้าได้รับงานหลังวัน Del date จะแสดงผลเป็น R ในช่อง Del date และ D ในช่อง Posts date (เงื่อนไขเก่า)

เงื่อนไขตามชีท data test
ผลลัพธ์ที่ต้องการตามชีท result ค่ะ
พอจะมีวิธีไหมคะ รบกวนแนะนำด้วยค่ะ ปวดสมองจริง ๆ

ขอบคุณค่ะ
p_d

[snasui]

ได้ปรับปรุง Code มาแล้วยังครับ

หากยังให้ปรับมาก่อน ติดตรงไหนค่อยถามกันต่อครับ

[p_d]

เรียน คุณ snasui

ยังไม่เข้าใจว่าจะทำอย่างไรให้ลบ partcode ที่ซ้ำกันแต่ค่า R และ D ที่แสดงในช่องวันที่ ยังอยู่ครบเหมือนเดิม เพราะเมื่อใช้ Code vb เพิ่มเข้าไปก็จะไปลบทั้งแถวทันที รบกวนชี้แนะด้วยค่ะ

Code: Select all

 Sub DeleteDups()
     
    Dim x               As Long
    Dim LastRow         As Long
     
    LastRow = Range("A65536").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x
     
End Sub

ขอบคุณค่ะ
p_d