separate ข้อมูล โดย VB

[dannyb]

เรียนคุณคนควนครับ

ขอรบกวนเขียน code VB แยกข้อมูลจากไฟล์ excel โดยต้องการให้อยู่ไฟล์เดิม แต่แยก sheet ตาม w/h ลองดู post ก่อนๆ ที่คนอื่นๆปรึกษา

แล้วลองปรับ range ดู แต่ข้อมูลไม่ขึ้นตามที่ต้องการ (ผมไม่มีความรู้เรื่อง VB เลย) และถ้าต้องการแก้ไข range ข้อมูล พอแนะนำได้ไหมครับ

ว่าควรปรับตรงไหนครับ

ข้อมูลตามไฟล์แนบครับขอบคุณล่วงหน้าครับ

[snasui]

ไม่พบ Code ในไฟล์แนบครับ

กรณีต้องการทำรายงานแยกชีทตาม w/h สามารถใช้ PivotTable มาช่วยได้ครับ

ดูตัวอย่างที่นี่ครับ http://www.snasui.com/viewtopic.php?p=7205#p7205

[dannyb]

ส่งไฟล์มาให้ใหม่แล้วครับ...ที่ไม่ทำ pivot เนื่องจากข้อมูลที่ให้เป็นข้อมูลดิบ ที่ต้องเอาไปทำงานต่อ..

ข้อมูลที่ export ออกมาจะปนๆกัน ต้องเสียเวลาในการ sort, filter, copy ซึ่งมีประมาณ 100 w/h

และข้อมูลที่แยกออกมาจะต้องนำไปคำนวณต่อ ซึ่งทำ pivot แล้วก็ต้องเสียเวลาในการ copy อยู่ดีครับ

รบกวนด้วย... code ที่ใส่มา copy มาจากกระทู้อื่น..ซึ่งลองปรับแล้วมันไม่มีอะไรเกิดขึ้นเลย

ขอบคุณครับ

[dannyb]

ลืมส่งไฟล์

[snasui]

ลองดู Code ตามด้านล่าง

Code: Select all

Sub SeparateData()
Dim a() As Variant, rAllrange As Range
Dim rAll As Range, rp As Range, rf As Range
Dim r As Range, count As Long
Dim lng As Long, i As Integer
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Worksheets("Sheet1")
    Set rAll = .Range("A3", .Range("A" & Rows.count).End(xlUp))
    Set rp = .Range("A3")
    Set rAllrange = .Range("A2", .Range("F" & Rows.count).End(xlUp))
    Set rf = .Range("H2")
End With
For Each r In rAll
    count = count + 1
    Set rp = rp.Resize(count, 1)
    If Application.CountIf(rp, r) = 1 Then
        ReDim Preserve a(lng)
        a(lng) = r
        lng = lng + 1
    End If
Next r
For i = LBound(a) To UBound(a)
    rf = a(i)
    rAllrange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("H1:H2")
    rAllrange.SpecialCells(xlCellTypeVisible).Copy
    Sheets.Add After:=Sheets(Sheets.count)
    Sheets(Sheets.count).Name = a(i)
    If Err <> 0 Then
        MsgBox "Check your sheet's name"
        ActiveSheet.Delete
        Sheets("Sheet1").ShowAllData
        Exit Sub
    End If
    ActiveSheet.Range("A1").PasteSpecial xlPasteValues
    Sheets("Sheet1").Activate
   Next i
Sheets("Sheet1").ShowAllData
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Finish"
End Sub

ดูไฟล์แนบประกอบครับ

[dannyb]

กราบขอบพระคุณงามๆครับ...
พอจะอธิบาย code ให้ผมเข้าใจแบบง่ายๆได้ไหมครับ..

[snasui]

กราบขอบพระคุณงามๆครับ...
พอจะอธิบาย code ให้ผมเข้าใจแบบง่ายๆได้ไหมครับ..

อธิบายหลักการแทนนะครับ
1. ต้องหาก่อนว่าในคอลัมน์ A มีกี่ค่าที่ต่างกัน เก็บค่านั้นไว้ก่อน
2. นำค่าที่เก็บนั้นมาทำการ Filter จากข้อมูลใน Sheet1
3. หลังจากได้ข้อมูลจากข้อ 2 แล้วก็ให้เพิ่มชีท โดยใช้ชื่อชีทตามค่าในข้อ 1
4. นำข้อมูลที่ได้ในข้อ 3 ไปวาง
5. ทำแบบนี้ไปเรื่อย ๆ จนครบทุกค่าที่เก็บไว้ตามข้อ 1
6. เมื่อทำครบแล้วให้แสดงข้อความ Finish
7. กรณีพบว่ามีชื่อชีทอยู่แล้วให้แสดงข้อความว่าให้ตรวจสอบชื่อชีท

[dannyb]

คุณคนควนครับ...

มีปัญหาอีกแล้วครับ...ข้อมูลที่ต้องการอยู่ในไฟล์แนบครับ...

กราบขอบพระคุณล่วงหน้างามๆครับ..

[snasui]

โอกาสหน้าการทำตัวอย่างควรเป็นตัวแทนของข้อมูลจริงครับ เว้นเสียจากว่าเข้าใจ Code VBA สามารถปรับแก้เองได้ สำหรับมือใหม่แล้ว Code พวกนี้เข้าใจไม่ง่ายนัก ซึ่งผมต้องขออภัยที่ไม่สามารถอธิบายอย่างละเอียด เนื่องจากไม่มีเวลาขนาดนั้นครับ

กรณีมีคำถามเพิ่มหรือคำอธิบายเพิ่มเติม ช่วยเขียนหรือ Copy ลงมาในฟอรัมนี้พอสังเขปด้วยครับว่าต้องการทำอะไร อย่างไร ส่วนรายละเอียดเขียนไว้ในไฟล์นั้นถูกต้องแล้วครับ การเขียนไว้ในฟอรัมด้วยจะอำนวยประโยชน์ในการ Search ของเพื่อน ๆ ครับ

คำถาม
1. กรณีไม่ลบชีท หากมีการ Update จะให้ข้อมูลต่อจากข้อมูลเดิมหรือแสดงอย่างไรครับ
2. กรณีต้องการ Clean Data วันที่ จะมีรูปแบบข้อความอยู่ในวงเล็บเสมอไปและต้องการลบข้อความรวมทั้งวงเล็บทิ้งไปใช่หรือไม่ครับ

[dannyb]

1. ข้อมูลจะถูกวางทับที่เดิมครับ..เพียงแต่ว่ามีข้อมูลเพิ่มขึ้น row เพิ่ม
แต่ column ไม่เพิ่ม
2. format วันที่ไม่รบกวนละนะครับ

[snasui]

ผมปรับ Code มาให้ใหม่ตามด้านล่าง

Code: Select all

Sub SeparateData()
Dim a() As Variant, rAllrange As Range
Dim rAll As Range, rp As Range, rf As Range
Dim r As Range, count As Long
Dim lng As Long, i As Integer, j As Integer
Dim wh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ClearAllSheets
SortCashData
With Worksheets("cash")
    Set rAll = .Range("B3", .Range("B" & Rows.count).End(xlUp))
    Set rp = .Range("B3")
    Set rAllrange = .Range("A2", .Range("F" & Rows.count).End(xlUp))
    Set rf = .Range("I3")
End With
For Each r In rAll
    count = count + 1
    Set rp = rp.Resize(count, 1)
    If Application.CountIf(rp, r) = 1 Then
        ReDim Preserve a(lng)
        a(lng) = r
        lng = lng + 1
    End If
Next r
For i = LBound(a) To UBound(a)
    rf = a(i)
    For Each wh In Worksheets
        If wh.Name = a(i) Then
            j = j + 1
        End If
    Next wh
    If j = 0 Then
        Sheets.Add After:=Sheets(Sheets.count)
        Sheets(Sheets.count).Name = a(i)
    End If
    Sheets("cash").Activate
    rAllrange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("I2:I3")
    rAllrange.SpecialCells(xlCellTypeVisible).Copy
    Worksheets(a(i)).Range("A1").PasteSpecial xlPasteValues
    Sheets("cash").Activate
    j = 0
   Next i
Sheets("cash").ShowAllData
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Finish"
End Sub

Sub SortCashData()
Dim r As Range
   Set r = Worksheets("cash").Range("A2").CurrentRegion
   With r
        .Sort Key1:=.Range("B1"), Order1:=xlAscending, Key2:=.Range("C1") _
        , Order2:=xlAscending, Key3:=.Range("A1"), Order3:=xlAscending, Header:= _
        xlGuess
    End With
End Sub

Sub ClearAllSheets()
Dim wh As Worksheet
For Each wh In Worksheets
    If wh.Name <> "cash" Then
        wh.Cells.Clear
    End If
Next wh
End Sub

ดูไฟล์แนบประกอบครับ