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, 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

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

Code: Select all

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

Code: Select all

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

Code: Select all

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

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

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