การแปลงข้อมูล

Bafnet · #41

สวัสดีครับอาจารย์ ขอรายงานผล
19.20 พบทางออกครับ
จากใช้เวลาแปลง/ลบ 20 นาทีกว่า
เหลือ15 วินาที

Sub DelZero()
Dim ri As Range
Dim ry As Range
Dim rx As Range
Dim cri As String
With Workbooks("DumP.xlsm").Worksheets("FileC")
Set ri = .Range(.Range("A2"), .Range("D65536") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)
  Set rx = .Range(.Range("A1"), .Range("D65536") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)
    
End With
With Workbooks("DumP.xlsm").Worksheets("Report")
Set ry = Workbooks("DumP.xlsm").Worksheets("Report").Range("A1")
End With
   Sheet10.Activate
           Sheet10.Range("A:D").AutoFilter Field:=4, Criteria1:=0
           
       ri.Select
       ri.Value = "0"
       Sheet10.ShowAllData
       Sheet10.Range("A:D").AutoFilter Field:=1, Criteria1:="<>0"
       rx.Select
       rx.Copy: ry.PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            Sheet10.Activate
            Sheet10.ShowAllData
            Sheet10.Range("A:D").ClearContents
Sheet10.Range("A:D").Value = Sheet18.Range("A:D").Value
End Sub

จากความรู้ที่อาจารย์มอบมาทั้งนั้นเลยครับ
ขอบคุณมากครับ
อืม

snasui wrote:Application.Calculation = xlCalculationManual

มันทำให้ค่าของ

Code: Select all

TextBox7.Value = Sheet10.Range("P1").Value
DoEvents

ไม่แสดงผลครับ

snasui · #42

ยินดีด้วยครับ

Bafnet wrote:จากความรู้ที่อาจารย์มอบมาทั้งนั้นเลยครับ
ขอบคุณมากครับ
อืม
snasui เขียน:
Application.Calculation = xlCalculationManual

มันทำให้ค่าของ
โค้ด: เลือกทั้งหมด
TextBox7.Value = Sheet10.Range("P1").Value
DoEvents
ไม่แสดงผลครับ

ปกติถ้าใช้ Code ปรับการคำนวณเป็น Manual แล้วก็ควรปรับการนำค่าในเซลล์ไปแสดงด้วยครับ เพราะว่ามันจะหยุดการคำนวณไปแล้ว

Code ด้านล่างผมทำตัวอย่างมาให้เห็นว่าเราสามารถใช้การนับค่าที่เราลบให้แสดงใน TextBox โดยไม่ต้องอ้างอิงค่าจากเซลล์ใน Worksheet

Code: Select all

Option Explicit

Sub Sed()
Dim r%, c%
Application.Calculation = xlCalculationManual
With Worksheets("Sheet2")
    .Activate
    r = .Range("A1").End(xlDown).Row
    Do Until r = 1
        If .Cells(r, 5).Value = 0 Then
            .Cells(r, 5).EntireRow.Delete
        End If
        r = r - 1
        c = c + 1
        UserForm1.TextBox1.Value = "Deleted " & c & " Items"
        DoEvents
    Loop
End With
Application.Calculation = xlCalculationAutomatic
End Su

Bafnet · #43

สวัสดีครับอาจารย์
มีปัญหาใหญ่ครับ อาจารย์จำได้ไหมครับเรื่องที่แปลงข้อมูล

Code: Select all

lngLr = Rows.Count
Worksheets("DataC").Range("A1:E1").Copy Worksheets("FileC").Range("A1")
With Worksheets("DataC")
    Set rs = .Range("A2", .Range("B2").End(xlDown))
End With
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("A" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
Next lng
Set rs = rs.Offset(0, 2).Resize(, 3)
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("C" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 3)
Next
'Worksheets("FileC").Range("B1").EntireColumn.Delete
Application.CutCopyMode = False
Sheet22.Range("A:Z").ClearContents
Sheet22.Range("A2").Activate
Sheet10.Activate
Sheet10.Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
DelZero.DelZero

วันนี้ผมได้ทดลองนำโปรแกรมไปโหลดFileC ของหน่วยอำเภอที่มีลูกค้ามากกว่าของผม

Code: Select all

Sub DelZero()
Dim ri As Range
Dim ry As Range
Dim rx As Range
Dim cri As String
With Workbooks("DumP.xlsm").Worksheets("FileC")
Set ri = .Range(.Range("A2"), .Range("D65536") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)
 Set rx = .Range(.Range("A1"), .Range("D65536") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)
    
End With
With Workbooks("DumP.xlsm").Worksheets("Report")
Set ry = Workbooks("DumP.xlsm").Worksheets("Report").Range("A1")
End With
 Sheet10.Activate
 
           Sheet10.Range("A:D").AutoFilter Field:=4, Criteria1:=0
           
       ri.Select
       ri.Value = "0"
       Sheet10.ShowAllData
       Sheet10.Range("A:D").AutoFilter Field:=1, Criteria1:="<>0"
       rx.Select
      rx.Copy: ry.PasteSpecial xlPasteValues
            Application.CutCopyMode = False
           Sheet10.Activate
            Sheet10.ShowAllData
            Sheet10.Range("A:D").ClearContents
Sheet10.Range("A:D").Value = Sheet18.Range("A:D").Value
End Sub

ปรากฏว่า DelZeRo ใช้การไม่ได้ ผมนั่งหาสาเหตุอยู่หลายชั่วโมงก็พบว่าเป็นเพราะจำนวนชุดข้อมูลที่เข้ามามีมากกว่า

Code: Select all

Set ri = .Range(.Range("A2"), .Range("D65536") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)

ประมาณ 70000 กว่า เลยต้องแก้ไขเป็น

Code: Select all

Set ri = .Range(.Range("A2"), .Range("D1048576") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)

ก็ได้ผลครับ หลังจากขจัดสัญญาที่เป็น 0 0 0 จาก 70000 เหลือ 20000
ก็ตกใจครับนั่งคิดว่านี่ขนาดสาขาต่างอำเภอเล็กๆ ไม่ใช่สาขาตัวจังหวัดซึ่งมีลูกค้ามากกว่านี้อีกมาก
ซึ่งมีปัญหาแน่ เพราะตอนแปลง 70000 กว่าขาดอีกไม่มากน้อยก็เต็มความจุ 1048576
ก็เลยต้องมาพึ่งอาจารย์ล่ะครับ
ตอนที่แปลงมาจากคำสั่งแรกด้านบนแบบฐานข้อมูล
อาจารย์ปรับให้ในขั้นตอนนั้นไม่นำส่วนที่เป็น 0 มาด้วยได้ไหมครับ
โดยมองที่ช่องจำนวนเงินเป็นหลักก็ได้ครับ คือถ้าเงินเป็นศูนย์ก็ไม่ต้องนำมา
รบกวนด้วยนะครับ
ขอบคุณครับ

Bafnet · #44

สวัสดีอีกครั้งครับ
อาจารย์ช่วยดูหน่อยนะครับ
จะทำอย่างไรให้ข้อมูลไปต่อท้ายครับ
ผมไม่ทราบจะทำยังไงแล้วครับ
เอามาเรียงได้แล้วโดยไม่เอาค่า0 แต่ส่งไปวางไม่ได้

แปลง.xlsm

snasui · #45

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

Code: Select all

Private Sub CommandButton1_Click()
Dim r As Integer
Dim ra As Range, rb As Range, rc As Range, rt As Range, rs As Range, ry As Range
Sheets("sheet1").Activate
r = 2
Do Until Sheet1.Cells(r, 1).Value = ""
    If Sheet1.Cells(r, 4) <> 0 Then
        Sheet1.Range("AA8").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB8").Value = Sheet1.Cells(r, 2).Value
        Sheet1.Range("AC8").Value = Sheet1.Cells(r, 3).Value
        Sheet1.Range("AD8").Value = Sheet1.Cells(r, 4).Value
    End If
    If Sheet1.Cells(r, 7) <> 0 Then
        Sheet1.Range("AA9").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB9").Value = Sheet1.Cells(r, 5).Value
        Sheet1.Range("AC9").Value = Sheet1.Cells(r, 6).Value
        Sheet1.Range("AD9").Value = Sheet1.Cells(r, 7).Value
    End If
    If Sheet1.Cells(r, 10) <> 0 Then
        Sheet1.Range("AA10").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB10").Value = Sheet1.Cells(r, 8).Value
        Sheet1.Range("AC10").Value = Sheet1.Cells(r, 9).Value
        Sheet1.Range("AD10").Value = Sheet1.Cells(r, 10).Value
    End If
    If Sheet1.Cells(r, 13) <> 0 Then
        Sheet1.Range("AA11").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB11").Value = Sheet1.Cells(r, 11).Value
        Sheet1.Range("AC11").Value = Sheet1.Cells(r, 12).Value
        Sheet1.Range("AD11").Value = Sheet1.Cells(r, 13).Value
    End If
    If Sheet1.Cells(r, 16) <> 0 Then
        Sheet1.Range("AA12").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB12").Value = Sheet1.Cells(r, 14).Value
        Sheet1.Range("AC12").Value = Sheet1.Cells(r, 15).Value
        Sheet1.Range("AD12").Value = Sheet1.Cells(r, 16).Value
    End If
    If Sheet1.Cells(r, 19) <> 0 Then
        Sheet1.Range("AA13").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB13").Value = Sheet1.Cells(r, 17).Value
        Sheet1.Range("AC13").Value = Sheet1.Cells(r, 18).Value
        Sheet1.Range("AD13").Value = Sheet1.Cells(r, 19).Value
    End If
    If Sheet1.Cells(r, 22) <> 0 Then
        Sheet1.Range("AA14").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB14").Value = Sheet1.Cells(r, 20).Value
        Sheet1.Range("AC14").Value = Sheet1.Cells(r, 21).Value
        Sheet1.Range("AD14").Value = Sheet1.Cells(r, 22).Value
    End If
    If Sheet1.Cells(r, 25) <> 0 Then
        Sheet1.Range("AA15").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB15").Value = Sheet1.Cells(r, 23).Value
        Sheet1.Range("AC15").Value = Sheet1.Cells(r, 24).Value
        Sheet1.Range("AD15").Value = Sheet1.Cells(r, 25).Value
    End If
    With Worksheets("Sheet1")
        Set rs = .Range("AA8", .Range("AD15")).SpecialCells(2)
        Set rc = .Range("AE" & Rows.Count).End(xlUp).Offset(1, 0)
    End With
    On Error Resume Next
    rs.Copy: rc.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    r = r + 1
    Sheet1.Range("AA8:AD15").ClearContents
Loop
End Sub

Bafnet · #46

สวัสดีครับอาจารย์
ท้อครับ

Code: Select all

If Sheet1.Cells(r, 4) <> 0 Then
        Sheet1.Range("AA8").Value = Sheet1.Cells(r, 1).Value
        Sheet1.Range("AB8").Value = Sheet1.Cells(r, 2).Value
        Sheet1.Range("AC8").Value = Sheet1.Cells(r, 3).Value
        Sheet1.Range("AD8").Value = Sheet1.Cells(r, 4).Value
    End If

ที่ผมเขียนมา
มันก็ยังเอาค่าว่างไปอยู่ดี เช่นสองบรรทัดแรกเป็นค่าว่าง มันก็เอาค่าว่างไปต่อท้ายด้วย
แถมช้ามากมายสู้ของอาจารย์

Code: Select all

lngLr = Rows.Count
Worksheets("DataC").Range("A1:E1").Copy Worksheets("FileC").Range("A1")
With Worksheets("DataC")
    Set rs = .Range("A2", .Range("B2").End(xlDown))
End With
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("A" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
Next lng
Set rs = rs.Offset(0, 2).Resize(, 3)
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("C" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 3)
Next
'Worksheets("FileC").Range("B1").EntireColumn.Delete

สู้ไม่ไดจริง ถ้าให้มันไม่เอาค่าศูนย์ก่อนจะไปเรียงเป็นแถวจาก Code นี้ได้ไหมครับ
ขอนะครับ
ก่อนแปลงแถวยาวๆ มี 8000 กว่า แปลงเสร็จมี 70000 กว่าบรรทัด แม้จะกรอง 0 ออกภายหลังได้
แต่มันก็รวนตอนที่ มาวาง70000 บรรทัดนี่แหละครับ
ดังนั้นจึงอยากให้มันไม่เอาค่า 0 มาตั้งแต่แรกครับ

สงสารผมนะ

Bafnet · #47

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

Code: Select all

Case "FILEC" '----------------¤Òº----------------------------------------------------------------
            cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + cData
            cn.Execute "DELETE * FROM FILEC_DUE "  'ÅéÒ§¢éÍÁÙÅ·Ñé§ËÁ´
            cSQL = "select *  from FILEC_DUE"
            rs.Open cSQL, cn, adUseClient, adLockPessimistic, adCmdText
            
            Set oPROG2 = frmMain.ProgressBar2
            Open sFileOpen For Input As #1
            While Not EOF(1)
                         Line Input #1, sTemp
                         iMAX = iMAX + 1
            Wend
            Dim sACC   As String
            Close #1
            Open sFileOpen For Input As #1
                    Do While Not EOF(1)
                            Line Input #1, sTemp
                            sACC = Mid(sTemp, 1, 8)
                            
                            If Mid(sTemp, 14, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 10, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 10, 2) '»Õ
                                rs.Fields(2).Value = Mid(sTemp, 12, 2) 'à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 14, 7)  ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 21, 4)  ' §Ç´´Í¡
                            If Mid(sTemp, 29, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 25, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 25, 2) ' »Õ
                                rs.Fields(2).Value = Mid(sTemp, 27, 2) ' à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 29, 7)  ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 36, 4) ' §Ç´´Í¡
                            If Mid(sTemp, 44, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 40, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 40, 2) ' »Õ
                                rs.Fields(2).Value = Mid(sTemp, 42, 2) ' à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 44, 7)  ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 51, 4)  ' §Ç´´Í¡
                            If Mid(sTemp, 59, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 55, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 55, 2) ' »Õ
                                rs.Fields(2).Value = Mid(sTemp, 57, 2) ' à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 59, 7) ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 66, 4) ' §Ç´´Í¡
                            If Mid(sTemp, 74, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 70, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 70, 2) ' »Õ
                                rs.Fields(2).Value = Mid(sTemp, 72, 2) ' à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 74, 7)  ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 81, 4)  ' §Ç´´Í¡
                            If Mid(sTemp, 89, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 85, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 85, 2) ' »Õ
                                rs.Fields(2).Value = Mid(sTemp, 87, 2) ' à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 89, 7) ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 96, 4) ' §Ç´´Í¡
                            If Mid(sTemp, 104, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 100, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 100, 2) ' »Õ
                                rs.Fields(2).Value = Mid(sTemp, 102, 2) ' à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 104, 7)  ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 111, 4)  ' §Ç´´Í¡
                            If Mid(sTemp, 119, 7) = "0000000" Then GoTo DOLOOP
                            rs.AddNew
                                rs.Fields(0).Value = sACC
                                'rs.Fields(1).Value = Mid(sTemp, 115, 4) ' §Ç´µé¹
                                rs.Fields(1).Value = Mid(sTemp, 115, 2) ' »Õ
                                rs.Fields(2).Value = Mid(sTemp, 117, 2) ' à´×Í¹
                                rs.Fields(3).Value = Mid(sTemp, 119, 7)  ' à§Ô¹
                                rs.Fields(4).Value = Mid(sTemp, 126, 4)  ' §Ç´´Í¡
DOLOOP: 'Ç¹ÅÙ»ãËÁè
                            iLine = iLine + 1
                            oPROG2 = iLine / iMAX * 100

                    Loop
            Close #1
            rs.Update
            oPROG2 = 0
            rs.Close: cn.Close

Code: Select all

380305241560400364005604560500252005605560900042005609570900042005709000000000000000000000000000000000000000000000000000000000000
400199861560400210005604000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
440073001500500050735005500900030005009510900030005109520900030005209530900030005309540900030005409550900030005509560900030005609
440073002570900030005709000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
360297261560400100005604560500090005605560900080005609570900130005709000000000000000000000000000000000000000000000000000000000000
370252851560500100005605000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
440159231500500063685005500900031845009510900031845109520900031845209530900031845309540900031845409550900031845509560900031845609
440159232570900031945709000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
430173001560500600005605560900150005609570900150005709580900150005809590900150005909600900150006009610900150006109620900223556209
430173002630900450006309000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
430173181470300010104703500900088005009510900088005109520900165905209530900088005309540900088005409550900088005509560900088005609
430173182570900088005709580900088005809590900088005909600900088006009610900088006109620900088006209630900098006309000000000000000
430173183000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
420271691540500022005405540900011005409550900011005509560900011005609570900055005709000000000000000000000000000000000000000000000
460027541540400210005404540500770005405540600210005406550600210005506560600210005606570600240005706580600250005806000000000000000
540013001550900100005509560900100005609570900100005709580900100005809590900100005909000000000000000000000000000000000000000000000
540013261550900200005509560900200005609570900200005709580900200005809590900200005909000000000000000000000000000000000000000000000
530030831540900340005409550900340005509560900340005609570900340005709580900340005809000000000000000000000000000000000000000000000
460085381540500250005405541200150005412551200150005512561200150005612571200150005712581200150005812591200150005912601200150006012
460085382611200150006112621200150006212631200150006312641200150006412651200150006512661200150006612000000000000000000000000000000
460085461500500000005005501200000005012511200000005112521200080005212531200080005312541200080005412551200080005512561200100005612

Bafnet · #48

สวัสดีครับ ขอรายงานผลครับ
ที่อาจารย์ปรับให้เพิ่ม ขอบคุณครับ
ช่องว่างหายไปต่อกันลงมาดีครับ
แต่ยังเทียบไม่ได้กับ Code ของอาจารย์อันนี้ครับ

Code: Select all

lngLr = Rows.Count
Worksheets("DataC").Range("A1:E1").Copy Worksheets("FileC").Range("A1")
With Worksheets("DataC")
    Set rs = .Range("A2", .Range("B2").End(xlDown))
End With
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("A" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
Next lng
Set rs = rs.Offset(0, 2).Resize(, 3)
For lng = 1 To 8
    Set rt = Worksheets("FileC").Range("C" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 3)
Next
'Worksheets("FileC").Range("B1").EntireColumn.Delete

ทั้งเร็วและแรง
ผมต้องขออภัยด้วยที่ดูจะวุ่นวาย แต่ผมก็ต้องพึ่งอาจารย์ล่ะครับ
ผมนั่งคิดดูพึ่งถึงบางอ้อ
มีแปดงวดต่อ1บรรทัด มี 8000 บรรทัดก็จะได้ผล 64000 บรรทัด แต่มีบรรทัดที่มีค่าจริงแค่ 29000 เป็น0 ซะ 35000
ถ้าเจอสาขาที่มีสัก 15000 บรรทัดซึ่งมีแน่นอน แล้ว *8 นิ่งสนิทแน่ครับ

snasui · #49

Bafnet wrote:สวัสดีอีกครั้งครับ
อาจารย์ช่วยดูหน่อยนะครับ
จะทำอย่างไรให้ข้อมูลไปต่อท้ายครับ
ผมไม่ทราบจะทำยังไงแล้วครับ
เอามาเรียงได้แล้วโดยไม่เอาค่า0 แต่ส่งไปวางไม่ได้
แปลง.xlsm

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

Code: Select all

Option Explicit

Sub ReRangeData()
Dim rs As Range, rt As Range, r As Range, rAll As Range
Dim lng As Long, lngLr As Long, i As Integer, c As Integer
Application.ScreenUpdating = False
lngLr = Rows.Count
Worksheets("Sheet1").Range("A1:D1") _
    .Copy Worksheets("Sheet2").Range("A1")
With Worksheets("Sheet1")
    Set rs = .Range("A2", .Range("A2").End(xlDown))
End With
    i = rs.Count
For lng = 1 To 8
    Set rt = Worksheets("Sheet2").Range("A" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    Set rs = rs.Offset(0, 1 + c).Resize(, 3)
    Set rt = Worksheets("Sheet2").Range("B" & lngLr).End(xlUp).Offset(1, 0)
    rs.Copy: rt.PasteSpecial xlPasteValues
    With Worksheets("Sheet2")
        Set rAll = .Range("C2").End(xlDown).Offset(-i + 1, 0).Resize(i)
    End With
    For Each r In rAll
        If r = 0 Then
            r = ""
        End If
    Next r
    rAll.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    With Worksheets("Sheet1")
        Set rs = rs.End(xlToLeft).Resize(i, 1)
    End With
    c = c + 3
Next lng
Application.ScreenUpdating = True
End Sub

Bafnet · #50

สวัสดีครับอาจารย์

หายไปหลายวัน..ไปอบรมมาครับ
รายงานผลครับ
จาก code ที่อาจารย์ให้มา ใช้ได้ดีครับ หลังจากที่ทดสอบโหลดและแปลงไฟล์C
จะมีก็ตอนที่มันคำนวณ Excel จะโชว์ not respond สักสองสามอึดใจ และแสดงอย่างงี้เป็นระยะๆ
อาจดูแล้วชวนตกใจ แต่ก็สำเร็จครับ ขอบคุณมากครับ

อาจารย์ครับวันนี้ขออนุญาตนำโจทย์เลขมาฝากนะครับ
ผม IF แล้ว If อีก แต่ยังดักไม่ได้รบกวนอาจารย์ดูหน่อยนะครับ
เป็นการเลื่อนงวดพักชำระหนี้ ในโครงการพักหนี้ครับ

งวดชำระ1.xlsx

หาทางออกให้หน่อยนะครับ
ขอบคุณครับ

snasui · #51

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

Bafnet · #52

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

งวดชำระ.xlsm

ขอบคุณมากๆครับ

snasui · #53

ดูตัวอย่างสูตรที่เซลล์ W31:W32 และคอลัมน์ AB ตามไฟล์แนบครับ

Bafnet · #54

สวัสดีครับอาจารย์

snasui wrote:ลองดูตัวอย่างการคำนวณตามไฟล์แนบครับ แยกเป็นคอลัมน์ช่วยในการคำนวณและช่วงผลลัพธ์ จะช่วยลดความซับซ้อนสามารถทำความเข้าใจได้ง่ายขึ้น

อาจารย์ครับทำไมเก่งจังครับ
ผมถามหน่อยนะครับ มันรู้ได้ยังไงครับว่าต้องขยายออกไป จำนวน 3 ปี_
จะว่าจากจำนวนบรรทัดที่เพิ่มขึ้นก็ไม่ใช่
รบกวนอธิบายหน่อยครับ
ขอบคุณครับ

snasui · #55

อยู่ที่การหา Logic เข้ามาจับครับ เงื่อนไขคือเดือน 5 และ ปีที่อยู่ถัดจากเดือน 5 จากตัวอย่างคือปี 57

จึงต้องมาหาความสัมพันธ์ว่า บรรทัดที่เป็นปี 57 กับเดือน 5 นั้นต่างกันกี่บรรทัดและบรรทัดที่ต่างกันนั้นสัมพันธ์กับจำนวนปีที่ต้องขยายไปอย่างไร จึงได้ออกมาเป็นสูตร

=4-(MATCH(57,E35:E40,0)-MATCH(5,F35:F40,0))

Bafnet · #56

สวัสดีครับ

snasui wrote:อยู่ที่การหา Logic เข้ามาจับครับ เงื่อนไขคือเดือน 5 และ ปีที่อยู่ถัดจากเดือน 5 จากตัวอย่างคือปี 57

จึงต้องมาหาความสัมพันธ์ว่า บรรทัดที่เป็นปี 57 กับเดือน 5 นั้นต่างกันกี่บรรทัดและบรรทัดที่ต่างกันนั้นสัมพันธ์กับจำนวนปีที่ต้องขยายไปอย่างไร จึงได้ออกมาเป็นสูตร

=4-(MATCH(57,E35:E40,0)-MATCH(5,F35:F40,0))

ถ้าตั้งข้อสังเกตุว่า เลข 4 ตัวหน้ามีความสัมคัญ
ถ้าผมให้ตำแหน่งหนึ่งสมมติ ว่าที่ A2 คือปีทีธนาคารระบุให้อนุญาตให้โครงการขยายออกไป 2 ปี
ดังนั้นที่ A2 = 3 (2+1)
=A2-(MATCH(57,E35:E40,0)-MATCH(5,F35:F40,0))
จะได้ไหมครับอาจารย์ผลของมันจะทำให้งวดแต่ละงวดขยายออกไปสองปีไหมครับ

ผมอยากให้โปรแกรมสามารถใช้งานได้ตลอดไปในอนาคต
หากธนาคารกำหนดขยายระยะเวลาใหม่อาจเป็น 1, 2, ...หรือ4
มี A2 = จำนวนปีที่ธนาคารอนุญาตให้ขยาย จะปรับอย่างไรให้
ที่อาจารย์ทำให้ใช้ได้ตลอดไป
ขอบคุณครับ

snasui · #57

ถ้าดูตาม Concept แล้วไม่น่าจะมีปัญหาใดครับ

Bafnet · #58

สวัสดีครับ
มีเรื่องอีกครับ

Code: Select all

Private Sub CommandButton1_Click()
Dim r As Integer
Dim m As Integer
If Sheet2.Range("A2").Value = "" Then
MsgBox "äÁèÁÕ¢éÍÁÙÅ", vbOKOnly, "DumP"
Exit Sub
End If
Sheet2.Range("Y1").Formula = "=COUNTIF(F:F,0)"
Sheet2.Activate
r = 2
Do Until Sheet2.Cells(r, 5).Value = ""
Sheet2.Cells(r, 19).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 5).Address & ",Dayco!A:D,2,0)"

Sheet2.Cells(r, 6).Value = Sheet2.Cells(r, 19).Value
Sheet2.Cells(r, 20).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 5).Address & ",Dayco!A:D,3,0)"

Sheet2.Cells(r, 7).Value = Sheet2.Cells(r, 20).Value
Sheet2.Cells(r, 21).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 5).Address & ",Dayco!A:D,4,0)"

Sheet2.Cells(r, 8).Value = Sheet2.Cells(r, 21).Value
Sheet2.Cells(r, 22).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 1).Address & ",Income!A:D,2,0)"

Sheet2.Cells(r, 19).Value = Sheet2.Cells(r, 22).Value
Sheet2.Cells(r, 22).Value = ""
Sheet2.Cells(r, 23).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 1).Address & ",Income!A:D,3,0)"

Sheet2.Cells(r, 20).Value = Sheet2.Cells(r, 23).Value
Sheet2.Cells(r, 23).Value = ""
Sheet2.Cells(r, 24).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 1).Address & ",Income!A:D,4,0)"

Sheet2.Cells(r, 21).Value = Sheet2.Cells(r, 24).Value
Sheet2.Cells(r, 24).Value = ""
r = r + 1
Loop
End Sub

รบกวนอาจารย์ปรับให้หน่อยครับ คือที่เว้นบรรทัดอยากให้มีคำสั่งตรวจค่าVlookuP ที่ #N/A ค่าError
ถ้าค่าที่เป็น Error ให้แสดงค่าเป็น ""

Code: Select all

Sheet2.Cells(r, 19).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 5).Address & ",Dayco!A:D,2,0)"
คำสั่งที่ดูก่อนว่าผลที่ Sheet2.Cells(r, 19) #N/A หรือไม่ถ้า เป็นก็ให้ Sheet2.Cells(r, 19)=""
Sheet2.Cells(r, 6).Value = Sheet2.Cells(r, 19).Value

ขอบคุณครับ

snasui · #59

ลองตามนี้ครับ

จาก

Bafnet wrote:Sheet2.Cells(r, 19).Formula = "=VLOOKUP(" & Sheet2.Cells(r, 5).Address & ",Dayco!A:D,2,0)"

เปลี่ยนเป็น

Code: Select all

Sheet2.Cells(r, 19).Formula = "=IF(ISNA(VLOOKUP(" & Sheet2.Cells(r, 5).Address & ",Dayco!A:D,2,0)),""""," & _
"VLOOKUP(" & Sheet2.Cells(r, 5).Address & ",Dayco!A:D,2,0))"

เปลี่ยนค่า Code อื่น ๆ เป็นแบบเดียวกัน > Run Code แล้วสังเกตดูผล และดูเหมือนยังพอใจกับการเลือกทั้งคอลัมน์อยู่เหมือนเดิมนะครับ

Bafnet · #60

สวัสดีครับ

snasui wrote:และดูเหมือนยังพอใจกับการเลือกทั้งคอลัมน์อยู่เหมือนเดิมนะครับ

snasui wrote:
Bafnet wrote:"=VLOOKUP(" & Sheet10.Cells(r, 1).Address & ",FileB!A1:T(n),3,0)"
จาก Statement ด้านบน (n) จะทำงานไม่ได้ เนื่องจากไม่ถือว่าเป็นตัวแปร แต่กลายเป็นส่วนหนึ่งของ String ,FileB!A1:T(n),3,0)

หากต้องการใช้ให้เป็นตัวแปรน่าจะเป็นตามด้านล่างครับ

"=VLOOKUP(" & Sheet10.Cells(r, 1).Address & ",FileB!A1:T" & n & ",3,0)"

ลองปรับใช้ดูครับ

อ่า..เคยเอาแบบนี้ไปลองใช้แต่ดันไปใช้ในค่าแรงค์
Sheet10.Range("A1:T" & n & ") มันบัคครับ
ก็เลยกลัวๆ เลยรักคอลัมน์ซะอย่างงั้น

ขอบคุณครับ

Snasui Excel Forum

File Anatomy Add-in: ตรวจสอบโครงสร้างไฟล์ Excel อย่างมืออาชีพ

การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล

Re: การแปลงข้อมูล