Save as Newfolder

[siamsrising]

สิ่งที่ต้องการคือต้องการ save as ทั้งไฟล์ excel เป็นไฟล์ใหม่และสร้าง folder หน้า Desktop โดยชื่อ folder แรก Desktop ให้เป็นชื่อ ใน Sheet (in) cloum C3 และเมื่อกดเข้าไปชื่อ ใน folder สอง ให้เป็นชื่อใน Sheet (in) cloum A3 ครับ แต่ตอนนี้ติดปัญหาคือ ผมไม่สามารถ save ได้ทั้งไฟล์ excel ทุกชีตครับแต่เหมือน save ออกมาแค่ชีทเดียวและสร้างขึ้นมาใหม่ เป็น ไฟล์ .csv แต่สิ่งที่ต้องการเป็นไฟล์ .xlsx ครับรบกวนอาจารย์และเพื่อนๆช่วยดูให้หน่อยครับ

Code: Select all

Private Sub CommandButton1_Click()
    Dim csvFilePath As String, csvdirF As String, csvdirD As String, iCount As Long, jCount As Long, kCount As Long, maxRow As Long
    Dim maxCol As Long, WSH As Variant, fileNo As Integer, FileNameT As String, FileNameD As String
    Dim FTY, STN, ctno As Variant
    
    
    FileNameT = Format(Now(), "hhmmss")
    FileNameD = Format(Now(), "yyyymmdd")
    
    Set WSH = CreateObject("WScript.Shell")
    FTY = Worksheets("in").Cells(3, 3) 'factory
    STN = Worksheets("in").Cells(3, 6) 'stlye
    'row/cloum
    ctno = Worksheets("in").Cells(1, 8).Value
    
   csvdirF = WSH.SpecialFolders("Desktop") & "\" & FTY
    
   csvdirD = csvdirF & "\" & FileNameD
   
    csvFilePath = csvdirD & "\" & STN & "-CTNo." & ctno & "_" & FileNameT & ".csv"
  
    maxRow = Cells(Rows.Count, 1).End(xlUp).Row
   maxCol = Cells(2, Columns.Count).End(xlToLeft).Column
    fileNo = FreeFile
    
Dim sc As Range, tg As Range
Dim tgBook As Workbook
With Sheets("IN")
lr = .Range("A" & Rows.Count).End(xlUp).Row
Set sc = .Range("A3:I10000" & lr)
sc.Copy
Sheets("Out").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
.PasteSpecial xlPasteValues
        
Set tgBook = Workbooks.Open(Filename:="C:\Users\Administrator\Desktop\GF SYTEM\Data.xlsm")
sc.Copy
tgBook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
.PasteSpecial xlPasteValues
 ActiveWorkbook.Save
 ActiveWorkbook.Close False

 
    If Dir(csvdirF, vbDirectory) = "" Then
     MkDir csvdirF
    End If
    If Dir(csvdirD, vbDirectory) = "" Then
      MkDir csvdirD
    End If
    Open csvFilePath For Output As #fileNo
    For iCount = 1 To maxRow
        For jCount = 1 To maxCol - 1
            If Not Cells(iCount, jCount) = "" Then
      Write #fileNo, Cells(iCount, jCount);
            End If
            kCount = jCount
        Next jCount
     
        Write #fileNo, Cells(iCount, kCount + 1)
    Next iCount
    Close #fileNo
End With


 Sheets("IN").Select
Range("A3:H1048576").Clear
Selection.ClearContents

Sheets("Out").Select
Range("A2:H1048576").Select
Selection.ClearContents

MsgBox "Done:"
Worksheets("IN").Select
Me.TextBox11.Text = Application.WorksheetFunction.Sum(Range("H3:H1048576"))
End Sub

[snasui]

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

[siamsrising]

ตอนนี้ที่ทำได้คือเมื่อกดปุ่ม Home และกดปุ่ม Save จะทำการ Save ไฟล์และสร้างโฟเดอร์ ขึ้นมาใหม่ในหน้า Desktop โดยโฟเดอร์ใหม่นั้นจะตั้งชื่อ ใน Cloum C3 และเมื่อกดเข้าไปในโฟเดอร์ใหม่ที่ตั้งชื่อแล้วนั้นจะพบโฟเดอร์ที่สร้างอีก 1 โฟเดอร์เป็นวันที่ที่ทำและเมื่อกดเข้าไปอีกจะพบไฟล์ที่เราบันทึกครับแต่ไฟล์นั้นจะเป็น .Csv และเป็นแค่ชีตเดียว
เช่น
เมื่อเราใส่ค่า
A3 Date : 9/10/2019
B3 Box : 2
C3 Factory : GG
D3 Barcode : 123456789
E3 Stlye : SKU
F3 Size : M
G3 Colors : WHITE
H3 No : 1
และทำการกดปุ่ม Home และปุ่ม Save ไฟล์ ก็จะดึงชื่อจาก cloum C3 มาเป็นโฟเดอร์แรก ก็คือโฟเดอร์ GG และเมื่อกดเข้าไปในโฟเดอร์ GG แล้วก็จะพบ โฟเดอร์วันที่ ที่ทำครับ และเมื่อกดเข้าไปก็จะพบงานที่ทำเป็น .CSV ครับ

แต่สิ่งที่ต้องการคือ ต้องการ Save ทั้งไฟล์ Needle.xlsm และทุกชีต เป็นไฟล์ .xlsx โดยแค่เปลี่ยนชื่อและสร้างโฟเดอร์ขึ้นมาใหม่ครับโดยชื่อ โฟเดอร์แแรกนั้นให้ดึงชื่อจาก Cloum C3 มาต้้งและเมื่อกดเข้าไปแล้วจะเป็นโฟเดอร์วันที่ที่ทำ และเมื่อกดเข้าไปอีกจะพบไฟล์งานของเราครับและตั้งชื่อไฟล์งานของเราโดยดึงชื่อ Cloum C3 มาเป็นชื่อนำครับ.xlsx
เช่น
เมื่อเราใส่ค่า
A3 Date : 9/10/2019
B3 Box : 2
C3 Factory : GG
D3 Barcode : 123456789
E3 Stlye : SKU
F3 Size : M
G3 Colors : WHITE
H3 No : 1
และทำการกดปุ่ม Home และปุ่ม Save ไฟล์ ก็จะดึงชื่อจาก cloum C3 มาเป็นโฟเดอร์แรก ก็คือโฟเดอร์ GG และเมื่อกดเข้าไปในโฟเดอร์ GG แล้วก็จะพบ โฟเดอร์วันที่ ที่ทำครับ และเมื่อกดเข้าไปอีกยากให้พบชื่อที่ทำเป็น GG.xlsx ครับ(ยากให้บันทึกทุกชีตครับ

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
Dim sBook As Workbook
FileNameT = Format(Now(), "hhmmss")
FileNameD = Format(Now(), "yyyymmdd")

Set WSH = CreateObject("WScript.Shell")
FTY = Worksheets("in").Cells(3, 3) 'factory
STN = Worksheets("in").Cells(3, 6) 'stlye

Set tbook = ThisWorkbook


'row/cloum
ctno = Worksheets("in").Cells(1, 8).Value

csvdirF = WSH.SpecialFolders("Desktop") & "\" & FTY

csvdirD = csvdirF & "\" & FileNameD

csvFilePath = csvdirD & "\" & STN & "-CTNo." & ctno & "_" & FileNameT

maxRow = Cells(Rows.Count, 1).End(xlUp).Row
maxCol = Cells(2, Columns.Count).End(xlToLeft).Column
'    fileNo = FreeFile
    

With Sheets("IN")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    Set sc = .Range("A3:I10000" & lr)
    sc.Copy
    Sheets("Out").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
        .PasteSpecial xlPasteValues
    If Dir(csvdirF, vbDirectory) = "" Then
     MkDir csvdirF
    End If
    If Dir(csvdirD, vbDirectory) = "" Then
      MkDir csvdirD
    End If
    Application.DisplayAlerts = False
    
    ThisWorkbook.Worksheets.Copy

    Set sBook = ActiveWorkbook
    sBook.SaveAs Filename:=csvdirF & "\" & FTY & ".xlsx", FileFormat:=51
    sBook.Close False
End With
'Other code

[siamsrising]

ืสามารถ เซฟเป็นไฟล์ .xlsx ได้แล้ว
สามารถสร้างโฟเดอร์ ที่ 1 เป็น cloum C3 ได้แล้วครับ
แต่ปัญหาคือ ไฟล์ .xlsx ไม่ได้เข้าไปอยู่ใน โฟเดอร์ที่ 2 ครับ แต่โฟเดอร์ขึ้นตามปกติ
เช่น
เมื่อใส่ข้อมูลครบแล้วแล้วทำการเซฟจะมีไฟล์ขึ้นในหน้า Desktop เป็นไฟล์ที่ดึงชื่อจาก cloum 3 และเมื่อกดเข้าไปจะพบไฟล์งานของเรา .xlsx อยู่ข้างนอกโฟเดอร์วันที่ ครับ
ผมยากให้ไฟล์งานเข้าไปอยู่ใน โฟเดอร์วันที่ ครับ รบกวนอาจารย์ช่วยดูหน่อยครับ

[snasui]

กรณีนี้ผมถือว่าควรจะปรับเองให้ได้เพราะแค่ปรับเปลี่ยนเล็กน้อยเท่านั้น

ให้ปรับ Code นี้ sBook.SaveAs Filename:=xxxx & "\" & FTY & ".xlsx", FileFormat:=51 ตรงตำแหน่ง xxxx โดยแทนด้วยตัวแปรที่เป็น Folder ที่ต้องการวางไฟล์ครับ

[siamsrising]

ได้แล้วครับขอบคุณมากครับ

[siamsrising]

สอบถามเพิ่มเตอมครับถ้าเราต้องการเซฟไฟไปไว้ที่อื่นที่ไม่ใช้หน้า Desktop เราต้องแก้ตรงไหนหรอครับ

[snasui]

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

sBook.SaveAs Filename:="D:\My Data\" & "\" & FTY & ".xlsx", FileFormat:=51

[siamsrising]

ถ้าผมต้องการเซฟไว้ในแชรไฟล์และโฟเดอร์ในแชรไฟล์ที่ผมตั้งขึ้น (REPORT1) และให้สร้างโฟเดอร์ขึ้น ตามปกติในสูตร excel ที่ทำ ต้องแก้ยังไงครับคือผมยากให้ข้อมูลเข้าไปสร้างใน โฟเดอร์ที่ผมต้งขึ้นครับ
เช่น
แชรไฟล์ - โฟเดอร์ report 1 - โฟเดอร์ที่เซฟ - โฟเดอร์ที่เซฟ - ไฟล์งาน

Code: Select all

    sBook.SaveAs Filename:="\\192.168.1.17\Sharing Files\REPORT1" & "\" & csvdirD & "\" & STN & "_" & FTY & ".xlsx", FileFormat:=51
    

[snasui]

ตัวอย่างสำหรับการสร้าง Folder มีอยู่แล้วใน Code ที่แนบมาถามกันคือ

Code: Select all

If Dir(csvdirF, vbDirectory) = "" Then
     MkDir csvdirF
End If
If Dir(csvdirD, vbDirectory) = "" Then
      MkDir csvdirD
End If

สามารถนำไปประยุกต์สร้าง Foder ใด ๆ ได้ตามต้องการครับ

[siamsrising]

ผมต้องการเซฟไฟล์ \\192.168.1.17\Sharing Files\REPORT1 ครับผมต้องแก้ตรงไหนครับ

[snasui]

แก้ Code มาเองก่อน ติดตรงไหนค่อยแนบไฟล์ที่ลองปรับเองแล้วถามกันต่อครับ

อีกประการที่สำคัญ การที่จะไปสร้าง Folder ใน Path ที่แชร์ไว้จะต้องมีสิทธิ์ในการ Write ด้วย ไม่เช่นนั้นจะสร้าง Folter ไม่ได้ครับ

[siamsrising]

Code: Select all

    sBook.SaveAs Filename:="\\192.168.1.17\Sharing Files\REPORT1" & "\" & csvdirD & "\" & STN & "_" & FTY & ".xlsx", FileFormat:=51
    

โค๊ดครับผมลองแล้วแต่เหมือนโค๊ด error ครับ

[snasui]

Code นี้ไม่เรียกว่าสร้าง Folder เป็นแค่เพียงวางไฟล์ใน Folder เท่านั้น ถ้าไม่มี Folder ให้วางก็ย่อมจะวางไม่ได้ ถือเป็นเรื่องปกติที่จะ Error ครับ

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

[siamsrising]

Code: Select all

Private Sub CommandButton2_Click()
    ActiveSheet.Shapes.Range(Array("CommandButton2")).Select
    Selection.Delete
    ActiveSheet.Shapes.Range(Array("CommandButton1")).Select
    Selection.Delete
Dim sBook As Workbook
FileNameT = Format(Now(), "hhmmss")
FileNameD = Worksheets("Digital Photo").Cells(4, 5)
Set WSH = CreateObject("WScript.Shell")
FTY = Worksheets("Digital Photo").Cells(5, 3) 'NO
FTR = Worksheets("Digital Photo").Cells(4, 7) 'factory
COT = Worksheets("Digital Photo").Cells(4, 3) 'co
STN = Worksheets("Digital Photo").Cells(5, 5) 'stlye
Set tbook = ThisWorkbook

ctno = Worksheets("Digital Photo").Cells(5, 3).Value
csvdirF = WSH.SpecialFolders("Desktop") & "\" & COT & "-" & FTR
csvdirD = csvdirF & "\" & FileNameD
csvdirE = WSH.SpecialFolders("\\192.168.1.17\Sharing Files\REPORT1")
csvFilePath = csvdirD & "\" & STN & "-CTNo." & ctno & "_" & FileNameT
maxRow = Cells(Rows.Count, 1).End(xlUp).Row
maxCol = Cells(2, Columns.Count).End(xlToLeft).Column
 '    fileNo = FreeFile
 
  If Dir(csvdirE, vbDirectory) = "" Then
     MkDir csvdirE
    End If
    
 If Dir(csvdirF, vbDirectory) = "" Then
     MkDir csvdirF
    End If
    
    If Dir(csvdirD, vbDirectory) = "" Then
      MkDir csvdirD
    End If
    
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets.Copy
    
    For iCount = 1 To maxRow
        For jCount = 1 To maxCol - 1
            If Not Cells(iCount, jCount) = "" Then
            End If
            kCount = jCount
        Next jCount
    Next iCount
    Close #fileNo

    Set sBook = ActiveWorkbook
    sBook.SaveAs Filename:=csvdirE & csvdirD & "\" & STN & "_" & FTY & ".xlsx", FileFormat:=51
    sBook.Close False

รบกวนอาจารย์ช่วยดูให้หน่อยครับ

[snasui]

ตัวอย่างการกำหนดตัวแปรให้แสดง Path ตามด้านล่างครับ

โดย Path ที่กำหนดให้ตัวแปรตามด้านล่างจะต้องมีอยู่จริงครับ

Code: Select all

'Other code
csvdirF = "\\192.168.1.17\Sharing Files\REPORT1" & "\" & COT & "-" & FTR
csvdirD = csvdirF & "\" & FileNameD
csvdirE = "\\192.168.1.17\Sharing Files\REPORT1"
'Other code

[siamsrising]

ขอบพระคุณมากครับ

[siamsrising]

งานสามารถเซฟได้ปกติกครับแต่ทำไมถ้าเป็นภาษาญี่ปุ่นไม่สามารถเซฟได้ครับ

[snasui]

กรณีที่เป็นภาษาอื่นนอกจากไทยและอังกฤษผมไม่สามารถช่วยตรวจสอบให้ได้ครับ