I have a simple question. I have an excel file with an invoice format being linked to around 30 odd invoice details from a table in a different sheet. I have already devised a macro to save each iteration as a separate excel file. But i want the 'filename' to be automated. For eg, if i select to print invoices for records 1-15, filenames should be saved as 1,2,3 and so on. The existing code is as follows -
Sub PrintForms()
Dim StartRow As Integer
Dim EndRow As Integer
Dim Msg As String
Dim i As Integer
Sheets("Invoice").Activate
StartRow = Range("StartRow")
EndRow = Range("EndRow")
If StartRow > EndRow Then
Msg = "ERROR" & vbCrLf & "The starting row must be less than the ending row!"
MsgBox Msg, vbCritical, APPNAME
End If
For i = StartRow To EndRow
Range("rowindex") = i
If Range("Preview") Then
Dim wb As Workbook
Set wb = Workbooks.Add
ThisWorkbook.Sheets("Invoice").Copy Before:=wb.Sheets(1)
wb.SaveAs "C:\workspace\1. Sem-1 Accounts\macrotest1.xlsx"
Else
ActiveSheet.PrintOut
End If
Next i
End Sub
Sub EditData()
Worksheets("Invoice Format").Activate
Range("A1").Select
End Sub
Sub ReturnToForm()
Worksheets("Invoice").Activate
Range("rowindex").Select
End Sub
End Sub
Related
I'm relatively new to VBA, I've been wanting to do the following, if at all possible, in VBA
Point towards CSV file
Loop through each row
Using the first value of each row - store the rest of the row in a specific worksheet
I've managed to do points 1 and 2, however, I'm struggling on Point 3
For example:
My CSV file is something like this:
A00,5675,TGI,6897
R88,7647,35968,35864
R88,5968,34531,44566
Z11,2245,FGH,YIU
I would like to read the first value of each row, in this case, A00, R88, R88 and Z11.
Then write that specific line to a corresponding worksheet based on the value.
For example, the A00 line would be written to a worksheet called A00 and so on.
I've gotten this far for reference:
Sub ImportFile()
Dim ws As Worksheet, strFile As String
strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...") 'Select file
'If first value = A00 - write to ActiveWorkbook.Sheets("A00")
'If first value = Z99 - write to ActiveWorkbook.Sheets("Z99")
Set ws = ActiveWorkbook.Sheets("A00") 'Export to this worksheet
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
End Sub
Any help would be much appreciated.
I've put together some VBA code that seems to work how you want. It reads the data file in line by line, splits this data into an array using the "," as a separator, sets the worksheet to the first element of the array, and then places the rest of the elements into cells on the first blank line.
Sub sGetData()
On Error GoTo E_Handle
Dim ws As Worksheet
Dim lngLastRow As Long
Dim strFile As String
Dim intFile As Integer
Dim strInput As String
Dim aData() As String
Dim lngLoop1 As Long
intFile = FreeFile
strFile = "J:\downloads\test3.txt"
Open strFile For Input As intFile
Do
Line Input #intFile, strInput
aData() = Split(strInput, ",")
Set ws = Worksheets(aData(LBound(aData)))
lngLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For lngLoop1 = LBound(aData) + 1 To UBound(aData)
ws.Cells(lngLastRow + 1, lngLoop1) = aData(lngLoop1)
Next lngLoop1
Loop Until EOF(intFile)
sExit:
On Error Resume Next
Close #intFile
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sGetData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
It could probably do with a bit of "bullet-proofing", to deal with things like the worksheet not existing and so on, but it should give you an idea.
Regards,
I have the following code that produces a new worksheet. I'm trying to name the new worksheet using a Phrase, the content in Cell 1, and the date in Cell 2.
Cell 1 will contain some data that are inserted via Data Validation (4 options in total) and Cell 2 will have a date.
EXAMPLE:
Worksheet INPUTS Range C3. Cell 1 value = Trade Activities, Purchases, Sales...etc
Worksheet INPUTS Range C2. Cell 2 value = 2.11.2020
The new workbook's name will be "Client Name Trade Activities - 2.11.2020"
both Cell 1 and Cell 2 will be in the INPUTS worksheet
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If ThisWorkbook.Worksheets("INPUTS").Range("C3").Value <> vbNullString Then
formatDate = Format(Sheets("INPUTS").Range("C3"), "YYYY.MM.DD")
End If
fileName = "Name - " & ActivityName & formatDate
sourceSheet.Outline.ShowLevels ColumnLevels:=1
sourceSheet.Range("A:M").AutoFilter Field:=12, Criteria1:="<>0"
Set targetWorkbook = Workbooks.Add
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
targetWorkbook.Sheets("sheet1").Columns("A:AC").EntireColumn.AutoFit
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".xlsx", FileFormat:=51
End Sub
Some things to remember:
Define and reuse your variables whenever you can
Try to add comments to your code, explaining the purpose of what you're doing (your future self or whom ever is going to work with your files, is going to thank you)
Leave spaces between your code's main parts, so it's more readable
EDIT: Added error handler, for when user clicks "No" when asking to overwrite existing file
Code:
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
On Error GoTo CleanFail
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
' Remove filter
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If sourceSheet.Range("F1").Value <> vbNullString Then
formatDate = Format(sourceSheet.Range("F1").Value, "YYYY.MM.DD")
End If
' Set the new workbook file name
fileName = "NAME - " & formatDate
' Filter the fileNames
sourceSheet.Range("A:C").AutoFilter Field:=2, Criteria1:="<>"
' Add new workbook and set reference
Set targetWorkbook = Workbooks.Add
' Copy the visible fileNames in a new workbook
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
' Save the new workbook
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".csv", FileFormat:=xlCSV
CleanExit:
Exit Sub
CleanFail:
Select Case Err.Number
Case 1004
MsgBox "You cancel the process"
Resume Next
Case Else
' Do something else? handle it properly...
MsgBox "Something went wrong..."
Resume CleanExit
End Select
End Sub
Let me know if it works
I found a macro that subtracts the values in one cell in a workbook from another cell in a workbook to output the result in a final third workbook. It exists as such
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim lngDiff As Long
On Error GoTo Err
Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
Set wb2 = Workbooks.Open("C:\FirstDataFile.xlsx")
Set wb3 = Workbooks.Open("C:\SecondDataFile.xlsx")
lngDiff = wb2.Sheets("Sheet1").Range("A1").Value - _
wb3.Sheets("Sheet1").Range("A1").Value
wb1.Sheets("Sheet1").Range("A1").Value = lngDiff
wb3.Close savechanges:=False
wb2.Close savechanges:=False
Application.ScreenUpdating = True
Exit Sub
Err:
MsgBox Err.Description
End Sub
Is there anyway to modify this code that it can do this for multiple lines at once.
For example. get it to subtract wb2.Sheets("Sheet1").Range("A1").Value - _
wb3.Sheets("Sheet1").Range("A1").Value and output that result into wb1.Sheets("Sheet1").Range("A1").Value and then do the same for A2, A3 and so on so forth until about A:120000? I would also like to be able to get this done on multiples sheets on the two books that I am drawing info from. How would this be done?
Thanks!
I suggest to use a loop through a list of worksheet names, and outsource the subtraction to subroutine InAllValuesOfColumnA that loops through all rows of each sheet as shown below. I further recommend to use meaningful variable names instead of numbered variables (which is a bad practice and easily gets mixed up).
Option Explicit
Public Sub ExampleSample()
Dim wbResult As Workbook, wbData As Workbook, wbSubtract As Workbook
Dim lngDiff As Long
On Error GoTo Err
Application.ScreenUpdating = False
Set wbResult = ActiveWorkbook
Set wbData = Workbooks.Open("C:\FirstDataFile.xlsx")
Set wbSubtract = Workbooks.Open("C:\SecondDataFile.xlsx")
Dim WorksheetList() As Variant
WorksheetList = Array("Sheet1", "Sheet2") 'add the worksheet names here
Dim WsName As Variant
For Each WsName In WorksheetList
InAllValuesOfColumnA OfWorksheet:=wbData.Worksheets(WsName), SubtractWorksheet:=wbSubtract.Worksheets(WsName), WriteToWorksheet:=wbResult.Worksheets(WsName)
Next WsName
wbData.Close SaveChanges:=False
wbSubtract.Close SaveChanges:=False
Application.ScreenUpdating = True
Exit Sub
Err:
MsgBox Err.Description
End Sub
Private Sub InAllValuesOfColumnA(ByVal OfWorksheet As Worksheet, ByVal SubtractWorksheet As Worksheet, ByVal WriteToWorksheet As Worksheet)
Dim LastRow As Long
LastRow = OfWorksheet.Cells(OfWorksheet.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 1 To LastRow 'run from first to last row and subtract
WriteToWorksheet.Cells(iRow, "A").Value = CLng(OfWorksheet.Cells(iRow, "A").Value - SubtractWorksheet.Cells(iRow, "A").Value)
Next iRow
End Sub
An even faster way would be to read/write the data into arrays before/after calculation:
Private Sub InAllValuesOfColumnA(ByVal OfWorksheet As Worksheet, ByVal SubtractWorksheet As Worksheet, ByVal WriteToWorksheet As Worksheet)
Dim LastRow As Long
LastRow = OfWorksheet.Cells(OfWorksheet.Rows.Count, "A").End(xlUp).Row
'read all into array
Dim DataColumn() As Variant
DataColumn = OfWorksheet.Range("A1:A" & LastRow).Value
Dim SubtractColumn() As Variant
SubtractColumn = SubtractWorksheet.Range("A1:A" & LastRow).Value
Dim ResultColumn() As Variant
ResultColumn = WriteToWorksheet.Range("A1:A" & LastRow).Value
Dim iRow As Long
For iRow = LBound(ResultColumn) To UBound(ResultColumn) 'run from first to last row and subtract
ResultColumn(iRow) = CLng(DataColumn(iRow) - SubtractColumn(iRow))
Next iRow
WriteToWorksheet.Range("A1:A" & LastRow).Value = ResultColumn
End Sub
First time poster here.
I have a list of files (file1, file2, file3) and I want to copy a range from those files into a master file. The master file contains a column with this data file1, file2, file3. How can I loop through that column and copy and paste each file's range into the corresponding row in the master? I need the data from file1 to go into a range in the same row as file1.
This is what I have so far:
Dim col As Range
Dim cell As Range
Dim currentRow As Long
Dim varCellValue As String
Dim pasteRangeC As String
Dim pasteRangeE As String
Set col = Range("B3:B5")
currentRow = 3
For Each cell In col
varCellValue = cell.Value
currentRow = 3
pasteRangeC = "C" & currentRow
pasteRangeE = "E" & currentRow
'## Open workbooks:
Set x = Workbooks.Open("C:\Folder\" & varCellValue &_ ".xlsx")
Set y = ThisWorkbook
'Copy from x:
x.Sheets("Summary").Range("D13:F13").Copy
'Paste to y worksheet:
y.Sheets("Sheet1").Range(pasteRangeC & ":" & pasteRangeE).PasteSpecial xlPasteValues
'Close x:
x.Close
currentRow = currentRow + 1
Next
End Sub
The code works for the first loop then I get a run-time error 1004 that the file cannot be found. So I'm thinking the varCellValue does not get the next cell's value.
Can anyone point me in the right direction?
Based on what I read try the following
Option Explicit 'Use every time will keep you from making simple mistakes...
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim wbSource As Workbook
Dim i As Integer
On Error GoTo ErrCatch 'add to catch errors
Set wb = Application.ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
For i = 1 To 5
'## Open workbooks:
Set wbSource = Workbooks.Open("C:\Folder\" & ws.Cells(i, 2).Value & ".xlsx") 'Cells(Row,Column) 2 = "B"
'Copy from wbSource and paste in worksheet
wbSource.Sheets("Summary").Range("D13:F13").Copy Destination:=ws.Cells(i, 3) 'This syntax keeps you from having to do "Application.CutCopyMode = False" to remove the marching ants.
'Close source:
wbSource.Close False
Next i
ErrCatch:
If Err.Number > 1 Then 'test if an error was thrown
MsgBox "Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description, vbCritical
End If
End Sub
I have an Excel 2010 workbook. I need to save the used range of each of its worksheets as a tab-delimited text file with no quotes, with the same filename as the workbook and with an extension given by the worksheet name.
Note that Excel stupidly surrounds a value by quotes whenever it sees a comma, even though the delimiter is a tab; other than that, the normal "Save As" / "Text (Tab delimited)" would be fine.
I would prefer to do that using VBA code from within Excel.
If there is a Python solution, I'd be interested too. But at this point pywin32 support for Python 3 is only experimental, so I am not sure I can use it.
Ok here is a slightly complex routine which I wrote couple of months back for one of my clients. This code exports the Excel Worksheet to a Fixed Width File without QUOTES. Screenshots also attached. I am sure this code can be made even better :)
TRIED AND TESTED
Option Explicit
'~~> Change this to relevant output filename and path
Const strOutputFile As String = "C:\Output.Csv"
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim MyArray() As Long, MaxLength As Long
Dim ff As Long, i As Long, lastRow As Long, LastCol As Long
Dim strOutput As String
On Error GoTo Whoa
Application.ScreenUpdating = False
'~~> Change this to the respective sheet
Set ws = Sheets("Sheet1")
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
'~~> Loop through each Column to get the max size of the field
For i = 1 To LastCol
MaxLength = getMaxLength(ws, i)
ReDim Preserve MyArray(i)
MyArray(i) = MaxLength
Next i
ff = FreeFile
'~~> output file
Open strOutputFile For Output As #ff
'~~> Write to text file
With ws
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For Each rng In .Range("A1:A" & lastRow)
With rng
For i = 1 To UBound(MyArray)
'~~> Insert a DELIMITER here if your text has spaces
strOutput = strOutput & " " & Left(.Offset(0, i-1).Text & _
String(MyArray(i), " "), MyArray(i))
Next i
Print #ff, Mid(Trim(strOutput), 1)
strOutput = Empty
End With
Next rng
End With
LetsContinue:
On Error Resume Next
Close #ff
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
'~~> Function to get the max size
Public Function getMaxLength(ws As Worksheet, Col As Long) As Long
Dim lastRow As Long, j As Long
getMaxLength = 0
lastRow = ws.Range("A" & ws.Rows.Count).End(-4162).Row
For j = 1 To lastRow
If Len(Trim(ws.Cells(j, Col).Value)) > getMaxLength Then _
getMaxLength = Len(Trim(ws.Cells(j, Col).Value))
Next j
End Function
Open your excel/csv/text
Perform your your required action and then You can saveas using file format as xlTextPrinter
ActiveWorkbook.SaveAs Filename:="Your File Name.txt", FileFormat:=xlTextPrinter, CreateBackup:=False
No need for extra code to replace extra quotes