:D snasui.com ยินดีต้อนรับ :D
ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย :thup: สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ :arrow: ระบุ Version ของ Excel
:!: โปรดทราบ :!:
  1. กรุณาอ่านกฎการใช้บอร์ด (Forum rules) ในตำแหน่งด้านบนของแต่ละบอร์ด
  2. การสมัครสมาชิก การ Login การกู้คืนรหัสผ่าน
    1. สมัครสมาชิกดูขั้นตอนได้ที่ :arrow: สมัครสมาชิก
    2. Login เข้าระบบโดยคลิกปุ่ม Login ตรงมุมขวาบนของหน้านี้ :roll:
    3. การ Login ผ่าน Facebook ดูวิธีที่ :arrow: Login ผ่าน Facebook
    4. ลืมรหัสผ่านสามารถรับรหัสใหม่ได้ที่ :arrow: Reset รหัสผ่าน
  3. มีปัญหาการใช้งาน แจ้งผู้ดูแลระบบได้ที่ :arrow: ติดต่อผู้ดูแลระบบ
  4. กำหนดการตั้งค่าส่วนตัว เช่นตั้งค่าภาษาเป็นไทยหรืออังกฤษดูได้ที่ :arrow: ตั้งค่าส่วนตัว
  5. การตั้งและตอบกระทู้ดูได้ที่ :arrow: วิธีการตั้งและตอบกระทู้
  6. การจัดรูปแบบตัวอักษรด้วย bbcode ในช่องแสดงความคิดเห็นดูได้ที่ :arrow: จัดรูปแบบตัวอักษร
  7. กำหนดขนาดตัวอักษรใน Browser ดูได้ที่ :arrow: กำหนดขนาดตัวอักษรใน Browser

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

ฟอรัมถาม-ตอบปัญหาการใช้งาน MS Excel and VBA
Forum rules
  1. ไม่อนุญาตให้ใช้ภาษาแชทในการถามและตอบปัญหา ไม่ใช้คำว่า "คับ" หรือ "อ่ะครับ" แทนคำว่า "ครับ" ไม่ใช้คำว่า "เด๋ว" แทนคำว่า "เดี๋ยว" เป็นต้น เนื่องจากเมื่อแปลเป็นภาษาต่างประเทศแล้วจะให้ความหมายผิดไปจากที่ควรจะเป็น
  2. ห้ามถามโดยระบุชื่อผู้ตอบและต้องตั้งชื่อกระทู้ให้สื่อถึงปัญหาที่จะถาม ไม่ตั้งชื่อว่า ช่วยด้วยครับ, มีปัญหามาปรึกษาครับ เป็นต้น
  3. กรุณาอธิบายปัญหาและระบุคำตอบที่ต้องการมาในกระทู้ด้วยเสมอถึงแม้จะอธิบายไว้ในไฟล์แนบแล้วก็ตาม ทั้งนี้เพื่ออำนวยความสะดวกแก่เพื่อนสมาชิกในการค้นหาข้อมูล
  4. กรุณาแนบไฟล์ตัวอย่างพร้อมแสดงคำตอบที่ถูกต้องมาในไฟล์ด้วยเพื่อให้ง่ายต่อการทำความเข้าใจและสะดวกต่อการตอบคำถาม (ขนาดไฟล์ไม่เกิน 500Kb ขนาดภาพไม่เกิน 800*600 Pixel) ไม่แนบเป็น Link มาจากแหล่งอื่นที่อาจจะถูกลบทิ้งไปโดยต้นทางในภายหลัง นอกจากนี้ไม่ควรแนบไฟล์ที่มีข้อมูลสำคัญอันก่อให้เกิดความเสียหายกับตนเองและผู้อื่น
  5. กรณีเป็นคำถามเกี่ยวกับ Programming เช่น VBA, VB.Net, C#, SQL ฯลฯ ต้องลองเขียนมาเองก่อนเสมอ ถามเฉพาะที่ติดปัญหา ระบุ Module, Procedure ที่ติดปัญหาให้ชัดเจน กรุณาโพสต์ Code ให้แสดงเป็น Code คือเปิดด้วย [code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
  6. กรุณาแจ้งผลการใช้งานเมื่อได้รับคำตอบว่าตรงกับความต้องการหรือไม่
kannaree
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#1

Post by kannaree »

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

ปุ่มที่ 1 Click import file
กำหนดให้ผู้ใช้ ระบุที่อยู่ของไฟล์และกดปุ่ม ข้อมูลจะถูก import มาลง sheet2 (ตามรูป)
1.png
Sheet2 แสดงข้อมูลที่ Import เข้ามา (ตามรูป)
2.png
ปุ่มที่ 2 ให้ผู้ใช้คลิกเพื่อทำการสร้างไฟล์ใหม่ โดยแยกข้อมูลตาม Column B
เมื่อผู้ใช้คลิก ปุ่ม (2) Create File
ผลลัพธ์จะได้ดังรูป
3.png

**** ซึ่งข้อมูลถูกแล้ว แต่อยากให้ไฟล์ที่วาง มาวางไว้ในโฟรเดอร์เดียวกันกับที่ผู้ใช้วางมา คือ 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


ขอบคุณค่ะ
You do not have the required permissions to view the files attached to this post.
kannaree
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#2

Post by kannaree »

แนบไฟล์ตัวอย่างค่ะ
CreateFileCopy - Copy.xlsm
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#3

Post by snasui »

:D ลองเพิ่ม 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
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#4

Post by kannaree »

รบกวนอาจารย์ด้วยค่ะ
CreateFileCopy - test(2).xlsm
Form.xlsx
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#5

Post by snasui »

:D ตัวอยา่งการปรับ 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
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#6

Post by kannaree »

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

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


You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#7

Post by snasui »

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

กรณีที่ติด Error ให้จับภาพมาด้วยว่าโปรแกรมฟ้องว่าอย่างไร จะได้สะดวกในการวินิจฉัยครับ
kannaree
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#8

Post by kannaree »

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
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#9

Post by snasui »

:D ภาพ Error เล็กมาก ไม่สามารถอ่านได้ครับ
kannaree
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#10

Post by kannaree »

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

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


You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30736
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#11

Post by snasui »

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

ผมแจ้งไปแล้วว่าให้เปลี่ยนไปเป็น Code ใด อ่านได้ที่ #5 ด้านบนครับ :roll:
kannaree
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#12

Post by kannaree »

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

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
You do not have the required permissions to view the files attached to this post.
User avatar
logic
Gold
Gold
Posts: 1506
Joined: Thu Mar 18, 2010 1:57 pm
Excel Ver: 365

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

#13

Post by logic »

มันฟ้องว่าให้เซฟชื่ออื่นไม่ใช่ไฟล์เดียวกับที่เปิดอยู่ งานแบบนี้ปกติจะเขียนให้เปลี่ยนชื่อไฟล์อย่าให้ซ้ำครับ
kannaree
Member
Member
Posts: 128
Joined: Thu Nov 19, 2015 12:07 pm

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

#14

Post by kannaree »

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