ปรึกษา Save as New Folder

[Leng]

สิ่งที่ต้องการครับ
-อยากให้ชื่อ Facetory เป็นชื่อของ New Folder ครับ (หลัก)1
-อยากให้ชื่อ Date ป็นชื่อของ New Folder ครับ (ย่อย)2
-อยากให้ชื่อ Stlye เป็นชื่อไฟล์ที่ Save (ไฟล์)3
-อยากให้ข้อมูล save ไปที่ data อีกไฟล์เพื่อรวมข้อมูล
ติดปัญหาคือข้อมูลไม่บันทึกลงไฟล์ที่สร้างใหม่ครับรบกวนช่วยดูหน่อยครับ

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, 4) 'factory
    STN = Worksheets("in").Cells(3, 6) 'stlye
    'row/cloum
    ctno = Worksheets("in").Cells(1, 9).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(1, 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:I5000" & 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\Test\Data.xlsx")
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:I1048576").Clear
Selection.ClearContents

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

 MsgBox "Done:"
Worksheets("IN").Select
End Sub

[snasui]

จากบรรทัดนี้

Set tgBook = Workbooks.Open(Filename:="C:\Users\Administrator\Desktop\Test\Data.xlsx")

ให้แนบไฟล์ที่ชื่อ Data.xlsx มาด้วยจะได้ช่วยทดสอบได้ครับ

[Leng]

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

[snasui]

กำหนดค่าตัวแปร maxCol ไว้ไม่ถูกต้องครับ

ที่ควรจะเป็นคือปรับ maxCol = Cells(1, Columns.Count).End(xlToLeft).Column เป็น maxCol = Cells(2, Columns.Count).End(xlToLeft).Column ครับ