Private Sub CommandButton1_Click()
' Macro controls exports of marked sheet data as text files to the
Transfer file directory
Msg = "Do you want to proceed with the concatenation of the 2
files?"
Ans = MsgBox(Msg, vbYesNo)
If Ans = vbYes Then
Call ExportToResult 'Call Sub Procedure
Else
End If
End Sub
SHEET1:
Private Sub Worksheet_Activate()
avoidloop = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo errorhandler
If avoidloop And Trim(Target) <> "" Then
If Target = "1" Then
Range("C2").Select
Application.SendKeys "{F2}"
Else
Select Case (ActiveCell.Column)
Case 1
avoidloop = False
If
UCase(Left(ActiveSheet.Rows(2).Columns(1).Value, 8)) =
UCase(Left(Target, 8)) Then
ActiveSheet.Rows(ActiveCell.Row -
1).Columns(1).Value = Target
ActiveSheet.Rows(ActiveCell.Row -
1).Columns(2).Value = ""
avoidloop = True
Else
ActiveSheet.Rows(ActiveCell.Row -
1).Columns(2).Value = Target
ActiveSheet.Rows(ActiveCell.Row -
1).Columns(1).Value = ""
ActiveSheet.Rows(10).Columns(3).Value =
"9999"
avoidloop = True
End If
Case 2
Case 3
If ActiveCell.Row = 3 Then
If Target <> "" Then SAVE_DATA (Target)
End If
Case Else
End Select
End If
End If
errorhandler:
End Sub
MODULE1:
Global avoidloop As Boolean
Sub Macro1()
Range("A2").Select
End Sub
Sub SAVE_DATA(Target)
GoldenSheet = ActiveSheet.Name
Sheets.Add
NewSheet = ActiveSheet.Name
Sheets(GoldenSheet).Select
Columns("A:E").Select
Selection.Copy
Sheets(NewSheet).Select
ActiveSheet.Paste
Rem For i = 1 To 100
Rem Sheets(NewSheet).Cells(i, 1) = Sheets(GoldenSheet).Cells(i,
1)
Rem Sheets(NewSheet).Cells(i, 2) = Sheets(GoldenSheet).Cells(i,
2)
Rem Sheets(NewSheet).Cells(i, 3) = Sheets(GoldenSheet).Cells(i,
3)
Rem Rem Sheets(NewSheet).Cells(i, 4) =
Sheets(GoldenSheet).Cells(i, 4)
Rem Rem Sheets(NewSheet).Cells(i, 5) =
Sheets(GoldenSheet).Cells(i, 5)
Rem Next i
FullPathFile = Trim(Sheets("Control").Cells(3, 3)) &
Trim(Sheets("Control").Cells(4, 3)) & Trim(Target) & "-" & Year(Now) &
"-" & Format(Month(Now), "00") & "-" & Format(Day(Now), "00") & ".xls"
increment = 1
Do While (Dir(FullPathFile) <> "")
trim_ = InStr(FullPathFile, "_")
trimxls = InStr(FullPathFile, ".xls")
parcialpath = Left(FullPathFile, trimxls - 1)
If trim_ > 1 Then
parcialpath = Left(parcialpath, trim_ - 1)
FullPathFile = parcialpath & "_" & increment & ".xls"
Else
FullPathFile = parcialpath & "_" & increment & ".xls"
End If
increment = increment + 1
Loop
Rem tempfilename = active
Range("A2").Select
ActiveSheet.Cells(2, 4) = Hour(Now) & ":" & Format(Minute(Now),
"00") & ":" & Format(Second(Now), "00")
ActiveSheet.Cells(2, 5) = Year(Now) & "-" & Format(Month(Now),
"00") & "-" & Format(Day(Now), "00")
Range("A2").Select
ActiveWindow.SelectedSheets.Move
ActiveWorkbook.SaveAs Filename:=FullPathFile, FileFormat:=xlNormal,
_
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close
Rem ActiveWorkbook.Close
avoidloop = False
For i = 2 To 100
Sheets(GoldenSheet).Cells(i, 1) = ""
Sheets(GoldenSheet).Cells(i, 2) = ""
Sheets(GoldenSheet).Cells(i, 3) = ""
Next i
avoidloop = True
If Sheets("Control").CheckBox1.Value Then MsgBox "File " &
FullPathFile & " Created"
Range("A2").Select
Application.SendKeys "{F2}"
End Sub
Sub TransferLocation()
'Macro inserts transfer directory name from control button
Location = Application.GetOpenFilename("All files (*.*), *.*")
If Location <> False Then
FindSeparator = InStr(Location, "\")
Do While FindSeparator
GetPath = Left(Location, FindSeparator)
FindSeparator = InStr(FindSeparator + 1, Location, "\")
Loop
EXPORTCONTROL.Cells(3, 3) = Trim(GetPath) 'display only path
Rem EXPORTCONTROL.Cells(3, 3) = Location ' display full name
& path
End If
Rem namesheets (True)
End Sub