Snasui Excel Forum

Posted: **Thu Feb 28, 2013 9:13 pm**

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

Private Sub CmdConvrt_Click()
    Dim Handle As Integer, File_Name As String
    Dim WriteRow As Long, TemArr, OneLine As String
    Dim Price1, Price2, Price3 As String
    Dim Pono() As Variant
    Dim Invno() As String
    Dim Chkval As Integer
    Dim Sump1 As Integer
    Dim Sump2 As Integer
    Dim Sump3 As Integer
    Dim Sumpr As Integer
    Dim Sumprice As Integer
    Handle = FreeFile
    File_Name = "D:\testrun.txt"
    Open File_Name For Input As #Handle
    Do While Not EOF(Handle)
        Line Input #Handle, OneLine
        TemArr = Split(OneLine, "|")
        If UBound(TemArr) > 1 Then
            WriteRow = WriteRow + 1
            Cells(WriteRow, 1) = "VMI050"
            Cells(WriteRow, 2) = TemArr(1)
            Cells(WriteRow, 3) = TemArr(2)
            'Pono = TemArr(4)
            Cells(WriteRow, 4) = TemArr(4)
            Cells(WriteRow, 5) = TemArr(5)
            Cells(WriteRow, 6) = TemArr(5)
            Cells(WriteRow, 7) = TemArr(7)
            Cells(WriteRow, 8) = TemArr(8)
            Cells(WriteRow, 9) = "   PC"
            If TemArr(4) = 9999999999# Then
                Cells(WriteRow, 9) = "     "
                Cells(WriteRow, 11).Value = Application.Sum( _
                    Range("K1:K" & WriteRow))
            End If
            If TemArr(29) = "S225-1-1011-001" Then
                Cells(WriteRow, 10) = Txtprc1.Value
                Cells(WriteRow, 11) = TemArr(8) * Txtprc1
                Sump1 = Cells(WriteRow, 11)
            ElseIf TemArr(29) = "S225-1-1211-002" Then
                Cells(WriteRow, 10) = Txtprc2.Value
                Cells(WriteRow, 11) = TemArr(8) * Txtprc2
                Sump2 = Cells(WriteRow, 11)
            ElseIf TemArr(29) = "S225-1-DUMM-001" Then
                Cells(WriteRow, 10) = Txtprc3.Value
                Cells(WriteRow, 11) = TemArr(8) * Txtprc3
                Sump3 = Cells(WriteRow, 11)
            End If
            'Cells(WriteRow, 11) = TemArr(8) * DC
            Cells(WriteRow, 12) = TemArr(9)
            Cells(WriteRow, 13) = TemArr(24)
            Cells(WriteRow, 14) = TemArr(25)
            Cells(WriteRow, 15) = TemArr(26)
            Sumpr = Sump1 + Sump2 + Sump3
            'Sumprice = Sumpr + Sumprice
            'Sumprice = Sumprice + Sumpr
        End If
        'Sumprice = Sumprice + Sumpr
    Loop
    Close #Handle
End Sub

Posted: **Sat Mar 02, 2013 4:28 pm**

ขอบคุณครับ
ทีนี้ผมดึงข้อมูลในคอลัมน์ D ที่ใส่ไว้ใน excel ขึ้นมาใส่ไว้ใน listbox1 แล้วผมต้องการที่จะเลือกข้อมูลที่อยู่ใน listbox1 ออกมาจำนวนหนึ่งแบบ move มาใส่ไว้ใน textbox2 แล้วพิมพ์ค่าที่จะแทนที่นั้นลงไปในคอลัมน์ D อย่างเช่นเลือก 21M0008243 21M0008255 21M0008262 21M0008266 4จำนวนนี้ออกมาแล้วแทน 4 ตัวนี้ให้เป็น INV1302001 ลงไปในคอลัมน์ D โดยพิมพ์ ค่า INV1302001 ใน combobox1

Code: Select all

Private Sub CmdConvrt_Click()
Dim Handle As Integer, File_Name As String
Dim WriteRow As Long, TemArr, OneLine As String
Dim Price1, Price2, Price3 As String
Dim Pono() As Variant
Dim Invno() As String
Dim Chkval As Integer
Handle = FreeFile
File_Name = "D:\testrun.txt"
Open File_Name For Input As #Handle
Application.Range("A1:z999") = ""
ListBox1.Value = Null
Do While Not EOF(Handle)
    Line Input #Handle, OneLine
    TemArr = Split(OneLine, "|")
    If UBound(TemArr) > 1 Then
        WriteRow = WriteRow + 1
        Cells(WriteRow, 1) = "VMI050"
        Cells(WriteRow, 2) = TemArr(1)
        Cells(WriteRow, 3) = TemArr(2)
        Cells(WriteRow, 4) = TemArr(4)
        ListBox1.AddItem (TemArr(4))
        ComboBox1.AddItem (TemArr(4))
        Cells(WriteRow, 5) = TemArr(5)
        Cells(WriteRow, 6) = TemArr(5)
        Cells(WriteRow, 7) = TemArr(7)
        Cells(WriteRow, 8) = TemArr(8)
        Cells(WriteRow, 9) = "   PC"
        If TemArr(4) = 9999999999# Then
        Cells(WriteRow, 9) = "     "
        Cells(WriteRow, 11).Value = Application.Sum(Range("K1:K" & WriteRow))
        End If
        If TemArr(29) = "S225-1-1011-001" Then
        Cells(WriteRow, 10) = Txtprc1.Value
        Cells(WriteRow, 11) = TemArr(8) * Txtprc1
        ElseIf TemArr(29) = "S225-1-1211-002" Then
        Cells(WriteRow, 10) = Txtprc2.Value
        Cells(WriteRow, 11) = TemArr(8) * Txtprc2
        ElseIf TemArr(29) = "S225-1-DUMM-001" Then
        Cells(WriteRow, 10) = Txtprc3.Value
        Cells(WriteRow, 11) = TemArr(8) * Txtprc3
        End If
        Cells(WriteRow, 12) = TemArr(9)
        Cells(WriteRow, 13) = TemArr(24)
        Cells(WriteRow, 14) = TemArr(25)
        Cells(WriteRow, 15) = TemArr(26)
    End If
Loop
Close #Handle
End Sub

Private Sub CmdSavefiles_Click()
    ChDir "D:\"
    ActiveWorkbook.SaveAs Filename:="D:\testfile.txt", FileFormat:=xlTextMSDOS, _
        CreateBackup:=False
End Sub

Private Sub RefEdit1_BeforeDragOver(Cancel As Boolean, ByVal Data As MSForms.DataObject, ByVal x As stdole.OLE_XPOS_CONTAINER, ByVal y As stdole.OLE_YPOS_CONTAINER, ByVal DragState As MSForms.fmDragState, Effect As MSForms.fmDropEffect, ByVal Shift As Integer)

End Sub



Private Sub ListBox1_Click()

End Sub

Private Sub ScrollBar1_Change()

End Sub

Private Sub Txtprc1_Change()
   If Me.Txtprc1.Value = "" Then Exit Sub
   On Error Resume Next
    With Me.Txtprc1
        Chkval = Evaluate(.Value)
        If Left(Chkval, 5) = "Error" Then
            MsgBox (" Input only number.")
            .Value = Left(.Value, Len(.Value) - 1)
        End If
    End With
End Sub

Private Sub Txtprc2_Change()
    If Me.Txtprc2.Value = "" Then Exit Sub
    On Error Resume Next
    With Me.Txtprc2
        Chkval = Evaluate(.Value)
        If Left(Chkval, 5) = "Error" Then
            MsgBox (" Input only number.")
            .Value = Left(.Value, Len(.Value) - 1)
        End If
    End With
End Sub

Private Sub Txtprc3_Change()
    If Me.Txtprc3.Value = "" Then Exit Sub
    On Error Resume Next
    With Me.Txtprc3
        Chkval = Evaluate(.Value)
        If Left(Chkval, 5) = "Error" Then
            MsgBox (" Input only number.")
            .Value = Left(.Value, Len(.Value) - 1)
        End If
    End With
End Sub

Posted: **Sat Mar 02, 2013 6:43 pm**

ได้เขียน Code สำหรับการทำเช่นนั้นแล้วยังครับ Code ชื่อว่าอะไร ติดขัดตรงบรรทัดไหนครับ

Posted: **Wed Mar 06, 2013 7:41 pm**

ตรง listbox ตัวซ้ายผมจะดึงข้อมูลจากคอลัมน์ D เข้ามาทั้งหมดแล้วเมื่อกดเลือก add ข้อมูลจะเข้ามา listbox ตัวขวาครับ
ทีนี้ผมต้องการให้ข้อมูลที่เลือกไว้ใน listbox ด้านขวาสมมติว่าเลือก 21M0008244 , 21M0008259 , 21M0008263
ทีนี้ผมต้องการแทนที่ข้อมูล 21M0008244 , 21M0008259 , 21M0008263 ลงไปในตำแหน่งที่ข้อมูลตัวนี้อยู่ด้วยตัว A
และเลือกข้อมูล add ชุดใหม่เข้ามา และใส่เป็น B ไปเรื่อยๆจนครบครับ
แล้วใน txtbox ด้านล่างผมใส่ A ลงไปและกดปุ่มเพื่อให้ข้อมูลโยนกลับเข้าไปแทนแต่ทำไม่ได้ครับ

Code: Select all

Private Sub CmdAddInv_Click()
If Application.Range("D1:D") = LstPoc.Value Then
Cells(WriteRow, 4) = TxtInv.Value
End If
End Sub

Private Sub CmdConvrt_Click()
Dim Handle As Integer, File_Name As String
Dim WriteRow As Long, TemArr, OneLine As String
Dim Price1, Price2, Price3 As Integer
Dim Pono() As Variant
Dim Invno() As String
Dim Chkval As Integer
Price1 = 1
Price2 = 2
Price3 = 3
Handle = FreeFile
File_Name = "D:\testrun.txt"
Open File_Name For Input As #Handle
Application.Range("A1:z999") = ""
LstPoa.Value = Null
Do While Not EOF(Handle)
    Line Input #Handle, OneLine
    TemArr = Split(OneLine, "|")
    If UBound(TemArr) > 1 Then
        WriteRow = WriteRow + 1
        Cells(WriteRow, 1) = "VMI050"
        Cells(WriteRow, 2) = TemArr(1)
        Cells(WriteRow, 3) = TemArr(2)
        Cells(WriteRow, 4) = TemArr(4)
        If TemArr(4) = 9999999999# Then
        Cells(WriteRow, 4) = 999999999999999#
        End If
        If TemArr(4) = 9999999999# Then
        TemArr(4) = ""
        Else
        LstPoa.AddItem (TemArr(4))
        End If
        Cells(WriteRow, 5) = TemArr(5)
        Cells(WriteRow, 6) = TemArr(5)
        Cells(WriteRow, 7) = TemArr(7)
        Cells(WriteRow, 8) = TemArr(8)
        Cells(WriteRow, 9) = "   PC"
        If TemArr(4) = 9999999999# Then
        Cells(WriteRow, 9) = "     "
        Cells(WriteRow, 11).Value = Application.Sum(Range("K1:K" & WriteRow))
        End If
        If TemArr(29) = "S225-1-1011-001" Then
        'Cells(WriteRow, 10) = Txtprc1.Value
        'Cells(WriteRow, 11) = TemArr(8) * Txtprc1
        Cells(WriteRow, 10) = Price1
        Cells(WriteRow, 11) = TemArr(8) * Price1
        ElseIf TemArr(29) = "S225-1-1211-002" Then
        Cells(WriteRow, 10) = Price2
        Cells(WriteRow, 11) = TemArr(8) * Price2
        ElseIf TemArr(29) = "S225-1-DUMM-001" Then
        Cells(WriteRow, 10) = Price3
        Cells(WriteRow, 11) = TemArr(8) * Price3
        End If
        Cells(WriteRow, 12) = TemArr(9)
        Cells(WriteRow, 13) = TemArr(24)
        Cells(WriteRow, 14) = TemArr(25)
        Cells(WriteRow, 15) = TemArr(26)
    End If
Loop
Close #Handle
End Sub

Private Sub CmdMove_Click()
LstPoc.AddItem (LstPoa.Value)
End Sub

Private Sub CmdSavefiles_Click()
    ChDir "D:\"
    ActiveWorkbook.SaveAs Filename:="D:\testfile.txt", FileFormat:=xlTextMSDOS, _
        CreateBackup:=False
End Sub

Private Sub Txtprc1_Change()
   If Me.Txtprc1.Value = "" Then Exit Sub
   On Error Resume Next
    With Me.Txtprc1
        Chkval = Evaluate(.Value)
        If Left(Chkval, 5) = "Error" Then
            MsgBox (" Input only number.")
            .Value = Left(.Value, Len(.Value) - 1)
        End If
    End With
End Sub

Private Sub Txtprc2_Change()
    If Me.Txtprc2.Value = "" Then Exit Sub
    On Error Resume Next
    With Me.Txtprc2
        Chkval = Evaluate(.Value)
        If Left(Chkval, 5) = "Error" Then
            MsgBox (" Input only number.")
            .Value = Left(.Value, Len(.Value) - 1)
        End If
    End With
End Sub

Private Sub Txtprc3_Change()
    If Me.Txtprc3.Value = "" Then Exit Sub
    On Error Resume Next
    With Me.Txtprc3
        Chkval = Evaluate(.Value)
        If Left(Chkval, 5) = "Error" Then
            MsgBox (" Input only number.")
            .Value = Left(.Value, Len(.Value) - 1)
        End If
    End With
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

End Sub

Private Sub LstPoa_Click()

End Sub

Posted: **Thu Mar 07, 2013 8:02 pm**

ลองปรับ Private Sub CmdAddInv_Click เป็นตามด้านล่างครับ

Code: Select all

Private Sub CmdAddInv_Click()
    Dim i As Integer, j As Integer
    Dim rAll As Range, r As Range
    With Sheets("bis225")
        Set rAll = .Range("D1", .Range("D" & Rows.Count).End(xlUp))
    End With
    i = LstPoc.ListCount
    For Each r In rAll
        For j = 0 To i - 1
            If r = LstPoc.List(j) Then
                r = TxtInv.Value
            End If
        Next j
    Next r
End Sub

Posted: **Mon Mar 11, 2013 8:28 pm**

ช่วยดู Private Sub CmdInsertRow ด้วยครับ
ต้องการที่จะแทรกบรรทัดที่ข้อมูลไม่ซ้ำกันออก โดยข้อมูลจะเรียงกัน ตรง คอลัมน์ D เช่น
01
01
01
01
แทรกข้อมูลเข้ามาครับ
02
02
02
แทรกข้อมูลเข้ามา
03
03
03
03
ตรงนี้ผมไม่รู้จะวนอย่างไรให้เจอบันทัดที่ข้อมูลในคอลัมน์ D ที่บรรทัดบนกันล่างไม่เหมือนกัน

เมื่อเจอแล้วผมจะลองแทรกและใส่ข้อมูลบางอย่างในแถวที่แทรกนี้ครับ

Posted: **Mon Mar 11, 2013 9:50 pm**

ตรวจสอบ บรรทัดบนกับล่าง

Code: Select all

Private Sub CmdInsertRow_Click()
    Dim i As Integer, j As Integer
    Dim rAll As Range, r As Range
    With Sheets("bis225")
        Set rAll = .Range("D1", .Range("D" & Rows.Count).End(xlUp))
    End With
    For Each r In rAll
           If r.Value = r.Offset(1, 0).Value Then
                  'your code
           Else
                  'your code
                  'r.EntireRow.Insert
           End If
    Next r
End Sub

Snasui Excel Forum

ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่นแล้ว

Re: ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่น

Re: ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่น

Re: ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่น

Re: ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่น

Re: ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่น

Re: ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่น

Re: ทำ vba ไว้ที่เครื่องตัวเองเปิดได้แต่ไปเปิดกับเครื่องอื่น