การบันทึกข้อมูลให้ต่อจากแุถวสุดท้ายของข้อมูล ด้วย VB

[tigerwit]

จากไฟล์ที่แนบ
ชีท report จะเป็นชีทที่กรอกข้อมูลรายการซื้อวัสดุของโรงเรียน
ต้องการที่จะบันทึกข้อมูลการซื้อแต่ละครั้งไปไว้ที่ชีท All
โดยให้รายการซื้อครั้งต่อไปบันทึกต่อท้ายแถวไปเรื่อยๆ
และที่ คลอลัมน์ A คลอลัมน์ B ต้องการใส่เลขที่ และวันที่ซื้อ ลงไปในทุกแถวที่มีรายการวัสดุ
ต้องปรับ Code อย่างไรครับ

Code: Select all

Sub RecData()
Application.ScreenUpdating = False
    Range("D4").Select
    Selection.Copy
    Sheet28.Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheet27.Select
    Range("G4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheet28.Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheet27.Select
    Range("B20:C56,E20:H56").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheet28.Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
     Range("C2").Select
            Sheet27.Select
        Application.CutCopyMode = False
           Range("D4").Select
           Application.ScreenUpdating = False

End Sub

[snasui]

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

Code: Select all

Dim rh As Range, rd As Range
Dim lr As Long
With Worksheets("Report")
    Set rh = Application.Union(.Range("d4"), .Range("g4"))
    lr = .Range("c" & .Rows.Count).End(xlUp).Row
    Set rd = Application.Union(.Range("b20:c" & lr), .Range("e20:h" & lr))
End With
With Worksheets("All")
    rh.Copy
    .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(rd.Rows.Count, 2) _
        .PasteSpecial xlPasteValues
    rd.Copy
    .Range("c" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(rd.Rows.Count, 5) _
        .PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False

[tigerwit]

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

Code: Select all

Sub RecCol()
Application.ScreenUpdating = False

    Range("D4").Select
    Selection.Copy
    Sheets("All2").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Report").Select
    Range("G4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("All2").Select
    Application.CutCopyMode = False
    Sheets("All2").Move Before:=Sheets(2)
    Sheets("Report").Select
    Range("D6").Select
    Selection.Copy
    Sheets("All2").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D2").Select
    Sheets("Report").Select
    Range("G6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("E2").Select
    Sheets("Report").Select
    Range("D8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F2").Select
    Sheets("Report").Select
    Range("D10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Report").Select
    Range("G10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Range("G2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Report").Select
    Range("D12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Range("H2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Report").Select
    Range("G12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Range("I2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J2").Select
    Sheets("Report").Select
    Range("H12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("K2").Select
    Sheets("Report").Select
    Range("D14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("L2").Select
    Sheets("Report").Select
    Range("E14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("M2").Select
    Sheets("Report").Select
    Range("G14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("N2").Select
    Sheets("Report").Select
    Range("H14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Report").Select
    Range("E16").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Range("O2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Report").Select
    Range("G16").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All2").Select
    Range("P2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.ScreenUpdating = True

End Sub

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Dim ra As Range, r As Range
Dim l As Long, i As Integer
With Worksheets("Report")
    Set ra = .Range("D4,G4,D6,G6,D8,D10,G10,D12,G12,H12,D14,E14,G14,H14,E16,G16")
End With
With Worksheets("All2")
    l = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Row
    For Each r In ra
        .Range("a" & l).Offset(0, i).Value = r.Value
        i = i + 1
    Next r
End With

[knine2465]

ขออนุญาตเจ้าของกระทู้หน่อยครับพอดีได้ทดลองโค๊ดที่อาจารย์แนะนำผลปรากฏว่าไม่เกิดการเปลี่ยนแปลงใดๆ เลยครับไม่ทราบว่าเกิดจากอะไร

[snasui]

ผมทดสอบไฟล์ที่แนบมาข้อมูลจะไปบันทึกที่ชีต All ได้ปกติ ไม่เกิดปัญหาใดครับ

[knine2465]

โค๊ดตัวนี้ครับอาจารย์ All2 ไม่ยอมบันทึก

ตัวอย่าง Code ครับ

Code: Select all

Dim ra As Range, r As Range
Dim l As Long, i As Integer
With Worksheets("Report")
    Set ra = .Range("D4,G4,D6,G6,D8,D10,G10,D12,G12,H12,D14,E14,G14,H14,E16,G16")
End With
With Worksheets("All2")
    l = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Row
    For Each r In ra
        .Range("a" & l).Offset(0, i).Value = r.Value
        i = i + 1
    Next r
End With

[snasui]

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

[tigerwit]

ขอบพระคุณครับ โค๊ดที่แนะนำมา ใช้งานได้ปกติครับ
เข้าใจว่าที่บอกว่าโค๊ดไม่ทำงานนั้น น่าจะเกิดจาก มีข้อมูลที่อยู่ในแถวล่างลงไปประมาณแถวที่ 16384-16385 ลองเลื่อนไปดูแล้วลบออกก่อนครับ

[knine2465]

โค๊ดสามารถทำงานได้แล้วครับ ขอบคุณครับ

[tigerwit]

จาก Code นี้

Code: Select all

Dim ra As Range, r As Range
Dim l As Long, i As Integer
With Worksheets("Report")
    Set ra = .Range("D4,G4,D6,G6,D8,D10,G10,D12,G12,H12,D14,E14,G14,H14,E16,G16")
End With
With Worksheets("All2")
    l = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Row
    For Each r In ra
        .Range("a" & l).Offset(0, i).Value = r.Value
        i = i + 1
    Next r
End With

ต้องการให้ตรวจสอบก่อนว่า ที่เซล D4 (ชีท Report) ว่างหรือไม่ ถ้าว่างให้แจ้งเตือนว่าต้องใส่เลขที่บันทึกก่อน
และตรวจสอบว่า ที่เซล D4 (ชีท Report) มีค่าซ้ำกับค่าในคลอลัมน์ A ของชีท All2 ถ้าซ้ำ ให้แจ้งเตือนว่าซ้ำ
ต้องปรับเพิ่มโค๊ด อย่างไรครับ

[snasui]

ตัวอย่าง code ครับ

Code: Select all

With Worksheets("All2")
	if .range("d4").value = "" then
		'Your message
	end if

	if Application.countifs(worksheets("Report").range("a:a"),.range("d4") > 0 Then
		'Your message
	end if
	'Other code
End With

[tigerwit]

ขอบคุณครับ จากโค๊ดที่แนะนำ

Code: Select all

Sub RecCol()
Application.ScreenUpdating = False
Dim ra As Range, r As Range
Dim l As Long, i As Integer

With Worksheets("All2")
    if Application.countifs(worksheets("All2").range("a:a"),.range("d4") > 0 Then
        MsgBox ("ข้อมูลซ้ำ")
    Exit Sub
    End If
End With
 
With Worksheets("Report")
    If Range("d4").Value = "" Then
        MsgBox ("ยังไม่กรอกเลขที่บันทึก")
        Exit Sub
    End If
    Set ra = .Range("D4,G4,D6,G6,D8,D10,G10,D12,G12,H12,D14,E14,G14,H14,E16,G16")
End With
With Worksheets("All2")
    l = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Row
    For Each r In ra
        .Range("a" & l).Offset(0, i).Value = r.Value
        i = i + 1
    Next r
End With
        Application.ScreenUpdating = True
End Sub

จะใช้งานได้ในกรณี เช็คค่าว่างใน D4 ส่วนเช็คค่าใน D4 ว่าซ้ำกับค่าใน คลอลัมน์ A ของชีท All2 นั้น ติดที่

Code: Select all

 if Application.countifs(worksheets("All2").range("a:a"),.range("d4") > 0 Then

ครับผม

[knine2465]

ลองปรับแก้ที่บรรทัดนี้ดูครับ
เปลี่ยนการตรวจจับจากซีท All2 เป็น ซีท Report และเพิ่มวงเล็บปิดเข้าไปอีก 1 อัน

Code: Select all

With Worksheets("Report")
    If Application.countifs(Worksheets("All2").Range("a:a"), .Range("d4")) > 0 Then
        MsgBox ("ข้อมูลซ้ำ")
    Exit Sub
    End If
End With

[tigerwit]

กรณีที่มีการผสานเซลในคลอลัมน์ D และ C
จะต้องปรับ Code อย่างไรครับ

Code: Select all

Dim rh As Range, rd As Range
Dim lr As Long
With Worksheets("Report")
    Set rh = Application.Union(.Range("d4"), .Range("g4"))
    lr = .Range("c" & .Rows.Count).End(xlUp).Row
    Set rd = Application.Union(.Range("b20:c" & lr), .Range("e20:h" & lr))
End With
With Worksheets("All")
    rh.Copy
    .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(rd.Rows.Count, 2) _
        .PasteSpecial xlPasteValues
    rd.Copy
    .Range("c" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(rd.Rows.Count, 5) _
        .PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub Recdata()
    Application.ScreenUpdating = False
    
    Dim rh As Range, rd As Range, rd1 As Range
    Dim lr As Long
    Application.ScreenUpdating = False
    With Worksheets("Report")
        Set rh = Application.Union(.Range("d4"), .Range("g4"))
        lr = .Range("c" & .Rows.Count).End(xlUp).Row
        Set rd = .Range("b20:c" & lr)
        Set rd1 = .Range("e20:h" & lr)
    End With
    With Worksheets("All")
        rh.Copy
        .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(rd.Rows.Count, 2) _
            .PasteSpecial xlPasteValues
        rd.Copy
        .Range("c" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(rd.Rows.Count, 2) _
            .PasteSpecial xlPasteValues
        rd1.Copy
        .Range("e" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(rd.Rows.Count, 4) _
            .PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
End Sub

[tigerwit]

ขอบคุณครับ