The following code is VBA code for an Excel macros. The objective is to read input from the file Impeller_hub.dat and to write it into copy_hub.dat. The error message I received stated that there's a type mismatch, Run-time error '13'. Where is the error and how can it be rectified?
Private Sub fn_write_to_text_Click()
Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim stream As TextStream
Dim stream2 As String
LastCol = ActiveSheet.UsedRange.Columns.Count
LastRow = ActiveSheet.UsedRange.Rows.Count
stream2 = "C:\Users\devanandd\Desktop\copy_hub.dat"
Set stream = fso.OpenTextFile("C:\Users\devanandd\Desktop\Files\NUMECA\Impeller_Hub.dat", stream2, True)
CellData = ""
For i = 1 To LastRow
For j = 1 To LastCol
CellData = Trim(ActiveCell(i, j).Value)
stream.WriteLine "The Value at location (" & i & "," & j & ")" & CellData
Next j
Next i
stream.Close
MsgBox ("Job Done")
End Sub
Something like this works for me (using as much from your code as possible):
Option Explicit
Option Private Module
Private Sub fn_write_to_text_Click()
Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
Dim fso As Object
Dim stream As Object
Dim stream2 As String
Dim i As Long
Dim j As Long
Set fso = CreateObject("Scripting.FileSystemObject")
LastCol = ActiveSheet.UsedRange.Columns.Count
LastRow = ActiveSheet.UsedRange.Rows.Count
stream2 = "C:\YOURPATH\Desktop\aaa.txt"
'Uncomment the next line if you do not have the file
'Set stream = fso.CreateTextFile(stream2, True)
Set stream = fso.OpenTextFile(stream2, 8) '8 is ForAppending
CellData = ""
For i = 1 To LastRow
For j = 1 To LastCol
CellData = Trim(ActiveCell(i, j).value)
stream.WriteLine "The Value at location (" & i & "," & j & ")" & CellData
Next j
Next i
stream.Close
MsgBox ("Job Done")
End Sub
The code below would work if you have the file aaa.txt on your desktop. If you do not have it write:
Set stream = fso.CreateTextFile(stream2, True) to create it and delete the line Set stream = fso.OpenTextFile(stream2,8).
If you want to read from file Impeller_hub.dat and to write to file copy_hub.dat, then you need two TextStream variables, and two separate calls of fso.OpenTextFile: one with second argument ForReading, the other with second argument ForWriting.
Or, if you want to add data to the end of file Impeller_hub.dat, then - as CLR already wrote - the second argument for fso.OpenTextFile should be ForAppending.
Related
I am using this code to convert rows to individual text files.
Sub SaveWorksheet()
Dim MyWorkbook As Workbook
Dim MyDataWorksheet As Worksheet
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyDataWorksheet = MyWorkbook.Sheets("Data")
Dim OutputFile As String
Dim CellValue As String
Dim CurrentRow As Long
Dim CurrentCol As Long
Dim CurrentCharacter As Long
Dim LastRow As Long
Dim MyString As String
LastRow = MyDataWorksheet.Cells(Rows.Count, "a").End(xlUp).Row
For CurrentRow = 2 To LastRow
OutputFile = "C:\Users\PARSAH\Music\ClobFiles" & CurrentRow & ".txt"
Open OutputFile For Output As #1
CellValue = MyDataWorksheet.Cells(CurrentRow, 7).Value
'Write #1, CellValue
Print #1, CellValue
Close #1
Next CurrentRow
MsgBox "Done"
End Sub
Can anyone help me to convert it into UTF-8 because I have 65531 files created I can't do it manually.
Give this a shot.
Sub SaveWorksheet()
Dim MyWorkbook As Workbook
Dim MyDataWorksheet As Worksheet
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyDataWorksheet = MyWorkbook.Sheets("Data")
Dim OutputFile As String
Dim CellValue As String
Dim CurrentRow As Long
Dim CurrentCol As Long
Dim CurrentCharacter As Long
Dim LastRow As Long
Dim MyString As String
Dim fso, f
LastRow = MyDataWorksheet.Cells(Rows.Count, "a").End(xlUp).Row
For CurrentRow = 2 To LastRow
OutputFile = "C:\Users\PARSAH\Music\ClobFiles-" & CurrentRow & ".txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(OutputFile, 8, True)
f.WriteLine MyDataWorksheet.Cells(CurrentRow, 7).Value
f.Close
Next CurrentRow
MsgBox "Done"
End Sub
I have made the following code where the aim is to save two ranges into a CSV file:
Sub Export_range_to_CSV()
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim range1 As Range
Dim range2 As Range
Set range1 = Sheets("sheet1").Range("G2:G4")
Set range2 = Sheets("sheet1").Range("G5:H53")
Application.DisplayAlerts = False
On Error GoTo err
Set myWB = ThisWorkbook
myCSVFileName = "filepath" & "\" & "name" & VBA.Format(VBA.Now, "yyyymmdd_hhmm") & ".csv"
range1.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
range2.Copy
.Sheets(1).Range("A4").PasteSpecial xlPasteValues
.SaveAs Filename:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
err:
Application.DisplayAlerts = True
End Sub
The code above does the job, but for range1 it has commas at the end of the string when saved as CSV. I need to remove these in order for a job downstream to work. How do I get rid of the commas at the end of range1?
This is how it looks once saved as the CSV file:
range1
- # X=Y, <- need to remove these commas
- # Z=U,
- # M=Q,
range2
- datetime,quantity
- 2021-03-05 23:00:00+00:00,17
- 2021-03-05 23:30:00+00:00,17
- 2021-03-06 00:00:00+00:00,17
- 2021-03-06 00:30:00+00:00,17
I think the problem comes from range1 only having a single column and as soon as range2 comes into play it assumes range1 should be two columns as well.
The last column is calculated by checking the last column of both the ranges. Whichever is higher will be taken. Let me explain it.
Let's say the data is till column J
Set range1 = Sheets("sheet1").Range("G2:G4")
Set range2 = Sheets("sheet1").Range("G5:J53")
Then in this scenario, there will be 3 commas added. Similarly if the last column is K in range2 and last column is H in range1 then there will be 3 commas added to the 1st range.
The same holds true when you reverse the range
Set range1 = Sheets("sheet1").Range("G5:J53")
Set range2 = Sheets("sheet1").Range("G2:G4")
Now the 2nd range will have extra commas
Solution
Read the data in an array and then remove the last comma. So once your Csv file is written, pass the file to this procedure and it will take care of the rest
The below code reads the csv in an array in one go and then checks every line if it has a , on the right. And if it has then it removes it. Finally it deletes the old csv and writes the new file by putting the array in the text file in one go. I have commented the code so you should not have a problem understanding it. But if you do then simply ask.
'~~> Example usage
Sub Sample()
CleanCsv "C:\Users\Siddharth Rout\Desktop\aaa.txt"
End Sub
'~~> Cleans csv
Sub CleanCsv(fl As String)
Dim MyData As String, strData() As String
Dim i As Long
'~~> Read the file in one go into an array
Open fl For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Check for "," and remove
For i = LBound(strData) To UBound(strData)
If Right(strData(i), 1) = "," Then
Do While Right(strData(i), 1) = ","
strData(i) = Left(strData(i), Len(strData(i)) - 1)
Loop
End If
Next i
'~~> Kill old file
Kill fl
'~~> Output the array in one go into a text file
Dim ff As Long
ff = FreeFile
Open fl For Binary As #ff
Put #ff, , Join(strData, vbCrLf)
Close #ff
End Sub
Remove Trailing Comma
You run exportRangesToCSV, while removeTrailingCommaInTextFile is being called near the end, and removeTrailingComma is being called by removeTrailingCommaInTextFile.
I tested it and it works, but keep in mind that I know very little about manipulating text files (2nd procedure) and that this is more or less the first Regex I've ever written (3rd procedure). It took me 'ages' to write them (not complaining). The 1st procedure is where I'm 'at home'.
Note the example of a classic error-handling routine in the 2nd procedure (yours is unacceptable: you're missing the Resume part). You could easily apply it to the 1st procedure.
Don't forget to adjust the values in the constants section.
The Code
Option Explicit
Sub exportRangesToCSV()
Const sName As String = "Sheet1"
Const sAddr As String = "G2:G4,G5:H53"
Const dFolderPath As String = "C:\Test"
Const dLeftBaseName As String = "Name"
Const dTimeFormat As String = "yyyymmdd_hhmm"
Const dFileExtension As String = ".csv"
Const dAddr As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sAddr)
Dim dFilePath As String
dFilePath = dFolderPath & "\" & dLeftBaseName _
& VBA.Format(VBA.Now, dTimeFormat) & dFileExtension
Application.ScreenUpdating = False
With Workbooks.Add()
Dim dCell As Range: Set dCell = .Worksheets(1).Range(dAddr)
Dim srg As Range
For Each srg In rg.Areas
dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
Set dCell = dCell.Offset(srg.Rows.Count)
Next srg
Application.DisplayAlerts = False
.SaveAs dFilePath, xlCSV
Application.DisplayAlerts = True
.Close False
End With
Application.ScreenUpdating = True
removeTrailingCommaInTextFile dFilePath, True
'wb.FollowHyperlink dFolderPath
End Sub
Sub removeTrailingCommaInTextFile( _
ByVal FilePath As String, _
Optional ByVal removeAllOccurrences As Boolean = False)
Const ProcName As String = "removeTrailingCommaInTextFile"
On Error GoTo clearError
Dim TextFile As Long: TextFile = FreeFile
Dim TempString As String
Open FilePath For Input As TextFile
TempString = Input(LOF(TextFile), TextFile)
Close TextFile
Open FilePath For Output As TextFile
Print #TextFile, removeTrailingComma(TempString, removeAllOccurrences)
Close TextFile
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & err.Number & "':" & vbLf _
& " " & err.Description
Resume ProcExit
End Sub
Function removeTrailingComma( _
ByVal SearchString As String, _
Optional ByVal removeAllOccurrences As Boolean = False) _
As String
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
If removeAllOccurrences Then
.Pattern = ",+$"
Else
.Pattern = ",$"
End If
removeTrailingComma = .Replace(SearchString, "")
End With
End Function
Edit
This solution will write directly to the text file without exporting. It may become slow if there are too many cells.
Arrays
Sub exportRangesToCSVArrays()
Const sName As String = "Sheet1"
Const sAddr As String = "G2:G4,G5:H53"
Const dFolderPath As String = "C:\Test"
Const dLeftBaseName As String = "Name"
Const dTimeFormat As String = "yyyymmdd_hhmm"
Const dFileExtension As String = ".csv"
Const dAddr As String = "A1"
Const Delimiter As String = ","
Dim wb As Workbook: Set wb = ThisWorkbook
Dim rg As Range: Set rg = wb.Worksheets(sName).Range(sAddr)
Dim aCount As Long: aCount = rg.Areas.Count
Dim Data As Variant: ReDim Data(1 To aCount)
Dim rData() As Long: ReDim rData(1 To aCount)
Dim cData() As Long: ReDim cData(1 To aCount)
Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1)
Dim srg As Range
Dim srCount As Long, scCount As Long
Dim drCount As Long, dcCount As Long
Dim n As Long
For Each srg In rg.Areas
n = n + 1
srCount = srg.Rows.Count: scCount = srg.Columns.Count
rData(n) = srCount: cData(n) = scCount
If srCount > 1 Or scCount > 1 Then
Data(n) = srg.Value
Else
Data(n) = OneCell: Data(1, 1) = srg.Value
End If
drCount = drCount + srCount
If scCount > dcCount Then
dcCount = scCount
End If
Next srg
Dim Result() As String: ReDim Result(1 To drCount)
Dim r As Long, i As Long, j As Long
For n = 1 To aCount
For i = 1 To rData(n)
r = r + 1
For j = 1 To cData(n)
Result(r) = Result(r) & CStr(Data(n)(i, j)) & Delimiter
Next j
Result(r) = removeTrailingComma(Result(r), True)
Next i
Next n
Dim dFilePath As String
dFilePath = dFolderPath & "\" & dLeftBaseName _
& VBA.Format(VBA.Now, dTimeFormat) & dFileExtension
Dim TextFile As Long: TextFile = FreeFile
Dim TempString As String
Open dFilePath For Output As TextFile
Print #TextFile, Join(Result, vbLf)
Close TextFile
'wb.FollowHyperlink dFolderPath
End Sub
How do I adapt this to work with another worksheet rather than the worksheet I have visible.
If (IsEmpty(Cells(RowNum, ColumnNum).Value)) Then
GoTo nextloop:
End If
I have moved parenthesis, tried including workbook name but I think I'm just not getting the syntax. I'm not very good with excel.
What I'm trying to achieve. Take all contents of a column, push the data into a bat file. Script will be launched from a button on another worksheet.
UPDATED Full Code: (Tried Ryan's answer, was getting error. Fixed it but then the script did nothing.)
Sub Send2Bat()
Dim ColumnNum: ColumnNum = 26 ' Column Z - I have the I J and K Columns concatenated there.
Dim RowNum: RowNum = 0
Dim objFSO, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("C:\Test\Convert.bat") 'Output Path
aFile = "C:\Test\Convert.bat"
Dim OutputString: OutputString = ""
Dim LastRow: LastRow = Application.ActiveSheet.Cells(Application.ActiveSheet.Rows.Count, ColumnNum).End(xlUp).Row
Do
nextloop:
RowNum = RowNum + 1
If (IsEmpty(Cells(RowNum, ColumnNum).Value)) Then
GoTo nextloop:
End If
OutputString = OutputString & Replace(Cells(RowNum, ColumnNum).Value, Chr(10), vbNewLine) & vbNewLine
Loop Until RowNum = LastRow
objFile.Write (OutputString)
Set objFile = Nothing
Set objFSO = Nothing
End Sub
I made an excel workbook and put some data in column z for Sheet 1 and Sheet 2.
And I tweaked your code to read as follows:
Sub Send2Bat()
Dim ColumnNum: ColumnNum = 26 ' Column Z - I have the I J and K Columns concatenated there.
Dim RowNum: RowNum = 0
Dim objFSO, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("C:\Test\Convert.bat") 'Output Path
aFile = "C:\Test\Convert.bat"
Dim OutputString: OutputString = ""
Dim targetSheet As Worksheet
Set targetSheet = Application.Worksheets("Sheet1")
Dim LastRow: LastRow = targetSheet.Cells(targetSheet.Rows.Count, ColumnNum).End(xlUp).Row
Do
RowNum = RowNum + 1
If Not (IsEmpty(targetSheet.Cells(RowNum, ColumnNum).Value)) Then
OutputString = OutputString & Replace(targetSheet.Cells(RowNum, ColumnNum).Value, Chr(10), vbNewLine) & vbNewLine
End If
Loop Until RowNum = LastRow
objFile.Write (OutputString)
Set objFile = Nothing
Set objFSO = Nothing
End Sub
And it produced the following file:
So then I updated the targetSheet name to "Sheet2"
Set targetSheet = Application.Worksheets("Sheet2")
and executed again. The file updated to this:
So, the code is good at least in its basic form. Do you have anything else updating the sheets or moving things around while this is happening?
I have borrowed code on how to export each row of spreadsheet to a separate .txt file and tweaked it to include a title row. How can I have it add all 86 columns in my sheet.
Sub SaveWorksheet()
Dim MyWorkbook As Workbook
Dim MyDataWorksheet As Worksheet
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyDataWorksheet = MyWorkbook.Sheets("Data")
Dim OutputFile As String
Dim CellValue As String
Dim CurrentRow As Long
Dim CurrentCol As Long
Dim CurrentCharacter As Long
Dim LastRow As Long
Dim MyString As String
LastRow = MyDataWorksheet.Cells(Rows.Count, "a").End(xlUp).Row
For CurrentRow = 2 To LastRow
'C:\Regan\regan.xlsm
OutputFile = "C:\Regan\sample" & CurrentRow & ".txt"
Open OutputFile For Output As #1
CellValue = MyDataWorksheet.Cells(1, 1).Value & vbTab & vbCrLf & MyDataWorksheet.Cells(CurrentRow, 1).Value & vbTab
'Write #1, CellValue
Print #1, CellValue
Close #1
Next CurrentRow
MsgBox "Done"
End Sub
The following code loops through each of the 86 columns:
Sub SaveWorksheet()
Dim MyWorkbook As Workbook
Dim MyDataWorksheet As Worksheet
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyDataWorksheet = MyWorkbook.Sheets("Data")
Dim OutputFile As String
Dim CellValue As String
Dim CurrentRow As Long
Dim CurrentCol As Long
Dim CurrentCharacter As Long
Dim LastRow As Long
Dim MyString As String
LastRow = MyDataWorksheet.Cells(Rows.Count, "a").End(xlUp).Row
For CurrentRow = 2 To LastRow
OutputFile = "C:\Regan\sample" & CurrentRow & ".txt"
Open OutputFile For Output As #1
'Write header record
For CurrentCol = 1 To 86
Print #1, MyDataWorksheet.Cells(1, CurrentCol).Value & vbTab;
Next
Print #1,""
'Write data record
For CurrentCol = 1 To 86
Print #1, MyDataWorksheet.Cells(CurrentRow, CurrentCol).Value & vbTab;
Next
Print #1,""
Close #1
Next CurrentRow
MsgBox "Done"
End Sub
My problem is when closing workbook2 I need to use code to automatically select No on a message box that pops up. This is how my code is laid out:
Workbook1 creates multiple files based on user input.
The loop in Workbook1 opens up Workbook2 and inputs data from Workbook1.
When the loop is done inputing data it closes workbook2 and a message box pops up with a Yes or No button on it.
User at this time should always select No.
Another window ask if the user would like to save and it should always be yes.
Loop continues until it has created all the files user has requested
I tried googling variations of my question but have not had much luck. Any help is much appreciated.
Dim JobName As String
Dim lngLoop As Long
Dim i As Integer
Dim Customer As String
Dim LastRow As Long
Dim iCus As Integer
Dim CompanyName As String
Dim d As Long
Dim strDir As Variant
Dim DIV As String
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim ActSheet As Worksheet
Dim ActBook As Workbook
Dim CurrentFile As Workbook
Dim NewFileType As String
Dim NewFile As String
Dim QTR_NUM As String
Dim MFG As String
Dim Job As String
Dim visitdate As Variant
Dim visitdate_text As String
Dim Quote_Request As Worksheet
Dim QTR As Workbook
Dim QTRLOG As Workbook
Dim FORM As Workbook
Dim DCSProgram As Workbook
Dim ILast As Long
Dim j As Integer
Dim k As Integer
Dim CustomerIDNum As String
Dim QTRNUM As String
Dim FolderName As String
'Creates Quote For Each MFG
For j = 0 To QTRList.ListCount - 1
Set QTRLOG = Workbooks.Open("C:\QTR LOG.xlsm")
Set QTR = Workbooks.Open("C:\QTR.xlsx")
'CODE TO INPUT DATA FROM USERFORM NEW QTR
With DCSProgram.Sheets("MFG_DATA")
ILast = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = MFG Then
QTR.Sheets(1).Range("B7").Value = .Cells(i, 2).Value
QTR.Sheets(1).Range("B8").Value = .Cells(i, 3).Value
QTR.Sheets(1).Range("B9").Value = .Cells(i, 4).Value
QTR.Sheets(1).Range("B12").Value = .Cells(i, 5).Value
QTR.Sheets(1).Range("B13").Value = .Cells(i, 6).Value
QTR.Sheets(1).Range("B14").Value = .Cells(i, 7).Value
QTR.Sheets(1).Range("B15").Value = .Cells(i, 8).Value
End If: Next: End With
With QTRLOG.Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 2) = QTRList.List(j)
'.Cells(i, 3) = FORM.Sheets(1).Range("H11").Value
.Cells(i, 5) = JobName
.Cells(i, 8) = "OPEN"
.Cells(i, 9) = QTR.Sheets(1).Range("H9").Value
End If: Next: End With
QTRLOG.Save
QTRLOG.Close
QTR.SaveAs Filename:="C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS\" & JobName & "\" _
& " DCS QTR " & QTRList.List(j) & " " & JobName & " (" & CustomerIDNum & ") " & visitdate_text & " .xlsx", _
FileFormat:=51, CreateBackup:=False, local:=True
'Code To Close File After Creating It
QTR.Close
Next j
End If
Application.ScreenUpdating = True
Call Shell("explorer.exe" & " " & "C:\Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\2. QUOTE REQUESTS", vbNormalFocus)
Unload NewQTR
End Sub
When this code runs a msgbox appears from the workbook QTR. I dont want the user to have to click yes or no at this time. I want to automatically select No and continue on to the next file. This process is repeated for each MFG.
Code in QTR:
Application.ScreenUpdating = True
MSG1 = MsgBox("Are you ready to email to MFG?", vbYesNo, "EMAIL MFG")
If MSG1 = vbYes Then
'Code to create email and attached workbook as PDF
Else
Const kPath As String = "C:\"
Const kFile As String = "Users\Geoffrey\Dropbox\DCS PROGRAM\FILES\9. PROGRAM FILES\1. QUOTE REQUEST\QUOTE REQUEST LOG.xlsm"
Dim TOTALFOB As Double
Dim TOTALWC As Double
Dim Wbk As Workbook
Dim INWBK As Workbook
Dim QTR_NUM As String
Dim ILast As Long
Dim i As Long
Dim TOTMFG As Variant
Dim TOTWC As Variant
Dim LR As Long
Dim TOTALTIME As Variant
Set INWBK = ThisWorkbook
With Sheets("QTR")
LR = .Range("I" & Rows.Count).End(xlUp).Row
TOTALFOB = WorksheetFunction.Sum(.Range("I23:I" & LR))
End With
TOTALWC = TOTALFOB + INWBK.Sheets("QTR").Range("D18").Value
QTR_NUM = INWBK.Sheets("QTR").Range("H7").Value
TOTALTIME = INWBK.Sheets("WS_LOG").Range("J3").Value
Rem Set Wbk in case it's open
On Error Resume Next
Set Wbk = Workbooks(kFile)
On Error GoTo 0
Rem Validate Wbk
If Wbk Is Nothing Then Set Wbk = Workbooks.Open(kPath & kFile)
With Workbooks("QUOTE REQUEST LOG.xlsm").Sheets("QTR_LOG")
ILast = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ILast
If .Cells(i, 1).Value = QTR_NUM Then
.Cells(i, 6) = TOTALFOB
.Cells(i, 7) = TOTALWC
.Cells(i, 10) = TOTALTIME
End If: Next: End With
Wbk.Save
Wbk.Close
End If
End Sub
If your problem is avoiding some Workbook_BeforeClose() event handler placed in "ThisWorkbook" code to be executed, then you must "enclose" the code lines that close the workbook like follows
Application.EnableEvents = False
' your code that closes the workbook
Application.EnableEvents = True
Exit Sub before end if is making the code exit earlier.
So remove the above mentioned one and check.