Snasui Excel Forum

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