[VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

kannaree · #1

สวัสดีค่ะอาจารย์และทุกๆคน
ดิฉันมีปัญหากับการสร้างไฟล์ใหม่ โดยอยากให้ ไฟล์ที่สร้างใหม่ ไปอยู่ในไดร์ ที่ได้กำหนด path ไป

ปุ่มที่ 1 Click import file
กำหนดให้ผู้ใช้ ระบุที่อยู่ของไฟล์และกดปุ่ม ข้อมูลจะถูก import มาลง sheet2 (ตามรูป)

: 1.png (17.28 KiB) Viewed 309 times

Sheet2 แสดงข้อมูลที่ Import เข้ามา (ตามรูป)

: 2.png (34.14 KiB) Viewed 309 times

ปุ่มที่ 2 ให้ผู้ใช้คลิกเพื่อทำการสร้างไฟล์ใหม่ โดยแยกข้อมูลตาม Column B
เมื่อผู้ใช้คลิก ปุ่ม (2) Create File
ผลลัพธ์จะได้ดังรูป

: 3.png (34.35 KiB) Viewed 309 times

**** ซึ่งข้อมูลถูกแล้ว แต่อยากให้ไฟล์ที่วาง มาวางไว้ในโฟรเดอร์เดียวกันกับที่ผู้ใช้วางมา คือ C:\Users\PUR_Kannaree\Desktop\test
จะทำต้องแก้ไข Code ตรงส่วนไหนค่ะ

Code: Select all

Sub Button3_Click()

Dim thisWB  As String

Dim newWB As String

    thisWB = ActiveWorkbook.Name
        
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
        
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
        
    Sheets("Sheet2").Select
        
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
            
        On Error Resume Next
            
        ActiveSheet.ShowAllData
            
        On Error GoTo 0
        
    End If
        
    Columns("B:B").Select
    Selection.Copy
        
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
            
        If lastrow <> Rows.count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
        
    End If
        
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
        
    Columns("A:A").Delete
        
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        
    lMaxSupp = Cells(Rows.count, 1).End(xlUp).Row
        
    For suppno = 2 To lMaxSupp
        
        Windows(thisWB).Activate

        supName = Sheets("tempsheet").Range("A" & suppno)
            
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
                
            Windows(thisWB).Activate

            Sheets("Sheet2").Select
            Cells.Select
                
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
                
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
                
            lastrow = Cells(Rows.count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
                
            Windows(newWB).Activate
            ActiveSheet.Paste

            ActiveWorkbook.Save
            ActiveWorkbook.Close
                
        End If
        
    Next
        
    Sheets("tempsheet").Delete
        
    Sheets("Sheet2").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

End Sub

ขอบคุณค่ะ

kannaree · #2

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

CreateFileCopy - Copy.xlsm: (31.27 KiB) Downloaded 18 times

snasui · #3

ลองเพิ่ม Code ตามด้านล่างครับ

ประกาศตัวแปรเป็น String และ Assign ค่าให้กับตัวแปรดังกล่าวเพื่อใช้ Path ที่จะวางข้อมูล

Code: Select all

Dim strDir As String
strDir = ActiveWorkbook.Range("a1").Value

ก่อนที่จะ Save As ให้เปลี่ยนโฟลเดอร์ตาม Statement ด้านล่างครับ

Code: Select all

ChDir (strDir)

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

kannaree · #4

รบกวนอาจารย์ด้วยค่ะ

CreateFileCopy - test(2).xlsm: (31.55 KiB) Downloaded 21 times

Form.xlsx: (12.97 KiB) Downloaded 21 times

snasui · #5

ตัวอยา่งการปรับ Code เฉพาะที่เปลี่ยนไปจากเดิมครับ

เปลี่ยนการประกาศตัวแปรใหม่เป็น

Code: Select all

Dim thisWB  As Workbook
Dim newWB As String
Dim strDir As String

กำหนดค่าให้ตัวแปร

Code: Select all

Set thisWB = ThisWorkbook
strDir = ThisWorkbook.Worksheets(1).Range("a1").Value

กรณีต้องการสลับหน้าต่าง

Code: Select all

Windows(thisWB.Name).Activate

เมื่อ Save ไฟล์ใหม่

Code: Select all

ChDir (strDir)
ActiveWorkbook.Save
ActiveWorkbook.Close

kannaree · #6

ขอบคุณค่ะอาจารย์แก้ไขโค้ดตามแล้วแต่ ติด Debug

: vvv.png (16.55 KiB) Viewed 285 times

Code: Select all

Sub Button3_Click()

Dim thisWB  As Workbook
Dim newWB As String
Dim strDir As String

     Set thisWB = ThisWorkbook
        strDir = ThisWorkbook.Worksheets(1).Range("a1").Value
    'thisWB = ActiveWorkbook.Name
        
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
        
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
        
    Sheets("Sheet2").Select
        
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
            
        On Error Resume Next
            
        ActiveSheet.ShowAllData
            
        On Error GoTo 0
        
    End If
        
    Columns("B:B").Select
    Selection.Copy
        
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
            
        If lastrow <> Rows.count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
        
    End If
        
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
        
    Columns("A:A").Delete
        
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        
    lMaxSupp = Cells(Rows.count, 1).End(xlUp).Row
        
    For suppno = 2 To lMaxSupp
        
        Windows(thisWB).Activate

        supName = Sheets("tempsheet").Range("A" & suppno)
            
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
                
            Windows(thisWB).Activate

            Sheets("Sheet2").Select
            Cells.Select
                
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
                
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
                
            lastrow = Cells(Rows.count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
                
            Windows(newWB).Activate
            ActiveSheet.Paste

            ChDir (strDir)
            ActiveWorkbook.Save
            ActiveWorkbook.Close
                
        End If
        
    Next
        
    Sheets("tempsheet").Delete
        
    Sheets("Sheet2").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

End Sub

snasui · #7

Code ตามด้านบนยังแก้ไม่ครบ ในเครื่องผมไม่พบว่าติด Error บรรทัดที่ Error ตามที่แจ้งมานั้นไม่ได้มีการแก้ไขใด ๆ เป็น Code เดิมล้วน ๆ

กรณีที่ติด Error ให้จับภาพมาด้วยว่าโปรแกรมฟ้องว่าอย่างไร จะได้สะดวกในการวินิจฉัยครับ

kannaree · #8

Code: Select all

Sub Button3_Click()

Dim thisWB  As Workbook
Dim newWB As String
Dim strDir As String

     Set thisWB = ThisWorkbook
     strDir = ThisWorkbook.Worksheets(1).Range("a1").Value
    'thisWB = ActiveWorkbook.Name
      Windows(thisWB.Name).Activate
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
        
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
        
    Sheets("Sheet2").Select
        
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
            
        On Error Resume Next
            
        ActiveSheet.ShowAllData
            
        On Error GoTo 0
        
    End If
        
    Columns("B:B").Select
    Selection.Copy
        
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
            
        If lastrow <> Rows.count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
        
    End If
        
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
        
    Columns("A:A").Delete
        
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        
    lMaxSupp = Cells(Rows.count, 1).End(xlUp).Row
        
    For suppno = 2 To lMaxSupp
        
        Windows(thisWB).Activate

        supName = Sheets("tempsheet").Range("A" & suppno)
            
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
                
            Windows(thisWB).Activate

            Sheets("Sheet2").Select
            Cells.Select
                
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
                
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
                
            lastrow = Cells(Rows.count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
                
            Windows(newWB).Activate
            ActiveSheet.Paste

            ChDir (strDir)
            ActiveWorkbook.Save
            ActiveWorkbook.Close
                
        End If
        
    Next
        
    Sheets("tempsheet").Delete
        
    Sheets("Sheet2").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

End Sub

Error แบบนี้ค่ะอาจารย์

: eeee.png (162.74 KiB) Viewed 280 times

snasui · #9

ภาพ Error เล็กมาก ไม่สามารถอ่านได้ครับ

kannaree · #10

อาจารย์คือหนูงงอะคะ หรือว่าหนูไปเพิ่ม Code ผิดตำแหน่ง ยังไม่สามารถทำได้เลยค่ะ

: wwww.png (86.93 KiB) Viewed 270 times

Code: Select all

Sub Button3_Click()

'Dim thisWB  As String
'Dim newWB As String
Dim thisWB  As Workbook
Dim newWB As String
Dim strDir As String

    'thisWB = ActiveWorkbook.Name
    Set thisWB = ThisWorkbook
    strDir = ThisWorkbook.Worksheets(1).Range("a1").Value
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
        
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
        
    Sheets("Sheet2").Select
    Windows(thisWB.Name).Activate
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
            
        On Error Resume Next
            
        ActiveSheet.ShowAllData
            
        On Error GoTo 0
        
    End If
        
    Columns("B:B").Select
    Selection.Copy
        
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
            
        If lastrow <> Rows.count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
        
    End If
        
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
        
    Columns("A:A").Delete
        
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        
    lMaxSupp = Cells(Rows.count, 1).End(xlUp).Row
        
    For suppno = 2 To lMaxSupp
        
       

        supName = Sheets("tempsheet").Range("A" & suppno)
            
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
                
            

            Sheets("Sheet2").Select
            Cells.Select
              
            If ActiveSheet.AutoFilterMode = False Then
                'Selection.AutoFilter
                Windows(thisWB.Name).Activate
            End If
                
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
                
            lastrow = Cells(Rows.count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
                
           
            ActiveSheet.Paste
            ChDir (strDir)
            ActiveWorkbook.Save
            ActiveWorkbook.Close
                
        End If
        
    Next
      Windows(thisWB).Activate
    Sheets("tempsheet").Delete
        
    Sheets("Sheet2").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

End Sub

snasui · #11

วาง Code ถูกแล้วครับ แต่ Code นี้ยังไม่ได้แก้ Windows(thisWB).Activate

ผมแจ้งไปแล้วว่าให้เปลี่ยนไปเป็น Code ใด อ่านได้ที่ #5 ด้านบนครับ

kannaree · #12

แก้ไขโค้ดแล้วยังไม่ได้เลยค่ะ อาจารย์

Code: Select all

Sub Button3_Click()

Dim thisWB  As Workbook
Dim newWB As String
Dim strDir As String

     Set thisWB = ThisWorkbook
        strDir = ThisWorkbook.Worksheets(1).Range("a1").Value
    'thisWB = ActiveWorkbook.Name
        
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
        
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
        
    Sheets("Sheet2").Select
        
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
            
        On Error Resume Next
            
        ActiveSheet.ShowAllData
            
        On Error GoTo 0
        
    End If
        
    Columns("B:B").Select
    Selection.Copy
        
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
        
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
            
        If lastrow <> Rows.count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
        
    End If
        
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
        
    Columns("A:A").Delete
        
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        
    lMaxSupp = Cells(Rows.count, 1).End(xlUp).Row
        
    For suppno = 2 To lMaxSupp
        
        Windows(thisWB.Name).Activate

        supName = Sheets("tempsheet").Range("A" & suppno)
            
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
                
           Windows(thisWB.Name).Activate

            Sheets("Sheet2").Select
            Cells.Select
                
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
                
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
                
            lastrow = Cells(Rows.count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
                
            Windows(thisWB.Name).Activate
            ActiveSheet.Paste

            ChDir (strDir)
            ActiveWorkbook.Save
            ActiveWorkbook.Close
                
        End If
        
    Next
        
    Sheets("tempsheet").Delete
        
    Sheets("Sheet2").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

End Sub

: qqqq.png (42.21 KiB) Viewed 261 times

logic · #13

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

kannaree · #14

ทำได้แล้วค่ะ ขอบคุณมากค่ะ

Snasui Excel Forum

File Anatomy Add-in: แก้ปัญหาไฟล์ Excel ช้า แฮงก์ และไม่เสถียร อย่างมืออาชีพ

[VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

[VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข

Re: [VBA] การสร้างไฟล์ใหม่แบบมีเงื่อนไข