Related
Heading ## I was able to get the selection to select active Cell a1 but now receive error 1004 Application Object-defined error, AT THE SECTION OF CODE <Sheets.Add before:=Workbooks(myFile).Sheets("Make DMS Report")>
Please see the code below.
The code filters the data from Agile export and filters the product Part number and associates the manufacture part number with the part.
'Start code
<Sub ImportAgileBOM()
'GoTo test1
Dim FullFileName As String
Dim myFile As String
Dim FileFormat As String
Dim rng As Range
'Open .cvs worksheet and convert to text format.
myFile = ActiveWorkbook.Name
FullFileName = Application.GetOpenFilename("Text files , *.csv; *.txt,Excel files (*.xls*), *.xls*", 2, "Select Agile Mfr BOM Report", , False)
If FullFileName = "False" Then
Application.DisplayAlerts = True
End
End If
'This section converts the .cvs and renames workboot to text
If Right(FullFileName, 4) = ".csv" Or Right(FullFileName, 4) = ".txt" Then
FileCopy FullFileName, FullFileName & "importtemp.txt"
FileFormat = "Text"
Workbooks.OpenText Filename:=FullFileName & "importtemp.txt", _
DataType:=xlDelimited, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2))
Else
FileFormat = "Excel"
Workbooks.Open Filename:=FullFileName
End If
'Make Active Range
Set rng = ActiveSheet.Range("A1")
'Range("A1").Activate
If FileFormat = "Text" Then
If ActiveCell <> "Manufacturer BOM Report" Then
MsgBox "Input file not in Manufacturer BOM Report format"
ActiveWindow.Close
Application.DisplayAlerts = True
End
End If
ElseIf ActiveCell.Offset(0, 1) <> "Manufacturer BOM Report" Then
MsgBox "Input file not in Manufacturer BOM Report format"
ActiveWindow.Close
Application.DisplayAlerts = True
End
End If
'FullFileName = ActiveWorkbook.Name
'Sheets(ActiveSheet.Name).Copy Sheets.Add Sheet.before:=Workbooks(myFile).Sheets("Make DMS Report")
'Windows(FullFileName).Activate
'ActiveWindow.Close savechanges:=False
'Copy data to secound sheet
FullFileName = ActiveWorkbook.Name
Cells.Select
Selection.Copy
Workbooks(myFile).Activate
Sheets.Add before:=Workbooks(myFile).Sheets("Make DMS Report")
ActiveSheet.Paste>
'I receive the error when trying to add the created sheet to the Active sheet.
If you could assist in this issue it would be appreciated
I am now receiving an error at <Range("A1"). select> the error message is Run-time error 1004 Application-defined Or Object-defined error, I don't understand why I am receiving this error, just selecting a cell
I have created a simple macro that will import 3 xls files into macro and will compare the data and will create a output file with limited fields. But I see my macro file is 33,446 KB even though the macro book sheets are empty.
is there any way to find out which line of code is taking time without doing step by step execution?
Input files & their file sizes
Excel macro file size
Sub Macro_Step_1()
Dim Wkb_1 As Workbook
Dim Autosht As Worksheet, DLDataSht As Worksheet, SAPdataSht As Worksheet, Osht As Worksheet
Set Wkb_1 = ThisWorkbook
Set Autosht = Wkb_1.Sheets("Automation")
Set DLDataSht = Wkb_1.Sheets("GLData")
Set SAPdataSht = Wkb_1.Sheets("YFIINTDSRP")
Set Osht = Wkb_1.Sheets("Output File")
Set Tempsht = Wkb_1.Sheets("Temp")
St = Now()
Call TurnOffStuff
wkbpath = Wkb_1.Path
'***************************************************************************************************************************************
FN = Dir(wkbpath & "\*.*")
Do While FN <> ""
Debug.Print FN
If LCase(FN) Like LCase("*Report*.xls") Then
Compinfo = Compinfo & "|" & FN
Compinfo = IIf(Left(Compinfo, 1) = "|", Mid(Compinfo, 2, Len(Compinfo)), Compinfo)
ElseIf LCase(FN) Like LCase("*Raw*.xlsx") Then
LMPTinfo = FN
End If
FN = Dir()
Loop
'*******************************************Input Files missing alert******************************************************************
If Compinfo = "" Or LMPTinfo = "" Then
ReportName = ""
ReportName = wkbpath & "\" & "Missing Input Files.txt"
Open ReportName For Output As #1
Close #1
Exit Sub
ReportName = ""
End If
'------------------------------------------------------------------------------
'//Clear Contents for Below mentioned Sheets Exluding Header
Wkb_1.Activate
DLDataSht.Rows("2:1000000").EntireRow.Clear
SAPdataSht.Rows("2:1000000").EntireRow.Clear
Tempsht.Rows("2:1000000").EntireRow.Clear
Osht.Rows("1:1000000").EntireRow.Clear
'*****************************Client Data***********************************************************************************************
RptName = Split(Compinfo, "|")
For Each Rsht In RptName
Call Copy_Compinfo_Data("" & Rsht & "", "", "YFIINTDSRP")
Next
Call Copy_LMPTinfo_Data("" & LMPTinfo & "", "", "GLData")
Call OutputMdl
Tempsht.Rows("1:1000000").EntireRow.Clear
'*********************************************************************************************************************************
Call TurnONStuff
'//Automation Run Time & Task Completetion Alert
MsgBox "Process Completed Within " & Format(Now() - St, "HH:MM:SS"), vbInformation
End Sub
Sub Copy_Compinfo_Data(IPWkb As String, IPSheet As String, DestSheetname As String)
Dim Del_1 As Long
Set Wkb_1 = ThisWorkbook
Set Tempsht = Wkb_1.Sheets("Temp")
Tempsht.Rows("1:1000000").EntireRow.Clear
wkbpath = ThisWorkbook.Path
ShtInx = IIf(IPSheet = "", 1, IPSheet)
Set ws_master = Workbooks.Open(wkbpath & "\" & IPWkb)
Shtname = ws_master.Sheets(1).Name
Set ws_Data = ws_master.Sheets(ShtInx)
Wkb_1.Activate
Set OrgFl = Wkb_1.Sheets(DestSheetname)
OrgFl.Select
ws_master.Sheets(1).Activate
Application.CutCopyMode = False
ws_Data.Cells.Copy
Tempsht.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ws_master.Activate
Windows(IPWkb).Close savechanges:=False
Wkb_1.Activate: Tempsht.Select
'HDRrow = 1
Tempsht.Rows("1:7").EntireRow.Delete
Tempsht.Range("A:A").EntireColumn.Delete
Tempsht.Rows("2:2").EntireRow.Delete
Tempsht.Range("C:C").EntireColumn.Delete
Tempsht.Sort.SortFields.Clear
Tempsht.Sort.SortFields.Add2 Key:=Range("A2:A" & LR), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Tempsht.Sort
.SetRange Range("A1:AB" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Wkb_1.Activate: Tempsht.Select
If Tempsht.AutoFilterMode Then Tempsht.AutoFilterMode = False
Tempsht.Range(Cells(1, 1), Cells(LR, LC)).AutoFilter field:=1, Criteria1:="Company Code"
If LR > 1 Then
Tempsht.Range(Cells(2, 1), Cells(LR, LC)).SpecialCells(xlCellTypeVisible).Delete
End If
Tempsht.ShowAllData
' For Del_1 = LR To 1 Step -1
'Wkb_1.Activate: Tempsht.Select
'Tempsht.Range(Cells(Del_1, 1), Cells(Del_1, LC)).Select
' Coun_ta = Application.WorksheetFunction.CountA(Tempsht.Range(Cells(Del_1, 1), Cells(Del_1, LR)))
' If Tempsht.Range("B" & Del_1) = "" And Coun_ta <= 0 Then
'Tempsht.Rows(Del_1).EntireRow.Select
'Tempsht.Rows(Del_1).EntireRow.Delete
' ElseIf Tempsht.Range("A" & Del_1) = "*" Then
'Tempsht.Rows(Del_1).EntireRow.Select
'Tempsht.Rows(Del_1).EntireRow.Delete
' End If
'Next
Wkb_1.Activate: Tempsht.Select
Tempsht.Cells(1, LC + 1) = "Report Name"
'Tempsht.Range(Cells(2, LC), Cells(LR, LC)).Select
Tempsht.Range(Cells(2, LC), Cells(LR, LC)) = IPWkb
Application.CutCopyMode = False
Tempsht.Range(Cells(2, 1), Cells(LR, LC)).Copy
Wkb_1.Activate
OrgFl.Select
OrgFl.Range("A" & LR + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Wkb_1.Activate: OrgFl.Select: OrgFl.Range("A1").Select
Application.CutCopyMode = False
End Sub
Sub Copy_LMPTinfo_Data(IPWkb As String, IPSheet As String, DestSheetname As String)
Set Wkb_1 = ThisWorkbook
Set Tempsht = Wkb_1.Sheets("Temp")
Set Osht = Wkb_1.Sheets("Output File")
Set DLDataSht = Wkb_1.Sheets("GLData")
Tempsht.Rows("1:1000000").EntireRow.Clear
DLDataSht.Rows("2:1000000").EntireRow.Clear
wkbpath = ThisWorkbook.Path
Set ws_master = Workbooks.Open(wkbpath & "\" & IPWkb)
Shtname = ws_master.Sheets(1).Name
Sht_Count = ws_master.Sheets.Count
For ShtInx = 1 To Sht_Count
Shtname = ws_master.Sheets(ShtInx).Name
Set ws_Data = ws_master.Sheets(ShtInx)
Wkb_1.Activate
Set OrgFl = Wkb_1.Sheets(DestSheetname)
OrgFl.Select
'OrgFl.Cells.Clear
ws_master.Sheets(Shtname).Activate
Application.CutCopyMode = False
ws_Data.Cells.Copy
Tempsht.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Tempsht.Rows("1:1").EntireRow.Delete
Tempsht.Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("F:F").TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("J:J").TextToColumns Destination:=Range("J1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("M:M").TextToColumns Destination:=Range("M1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("Q:Q").TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("U:U").TextToColumns Destination:=Range("U1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Tempsht.Columns("G:H").NumberFormat = "MM/DD/YYYY"
TEmpLastRow = Tempsht.Cells(Rows.Count, 3).End(xlUp).Row
Tempsht.Columns("A").Insert: Tempsht.Range("A1") = "Month"
Wkb_1.Activate: Tempsht.Select
Tempsht.Range(Cells(2, "A"), Cells(TEmpLastRow, "A")) = Shtname & "'" & Format(Now(), "YY")
Wkb_1.Activate: Tempsht.Select
Application.CutCopyMode = False
Tempsht.Range(Cells(2, 1), Cells(LR, LC)).Copy
Wkb_1.Activate
DLDataSht.Select
LastRow = DLDataSht.Cells(Rows.Count, 3).End(xlUp).Row
DLDataSht.Range("A" & LastRow + 1).PasteSpecial
Application.CutCopyMode = False
ws_master.Activate
Next
Windows(IPWkb).Close savechanges:=False
End Sub
Sub OutputMdl()
Set Wkb_1 = ThisWorkbook
Set Autosht = Wkb_1.Sheets("Automation")
Set DLDataSht = Wkb_1.Sheets("GLData")
Set SAPdataSht = Wkb_1.Sheets("YFIINTDSRP")
Set Osht = Wkb_1.Sheets("Output File")
Set Tempsht = Wkb_1.Sheets("Temp")
Osht.Rows("1:1000000").EntireRow.Clear
Wkb_1.Activate: Osht.Select
Wkb_1.Activate: DLDataSht.Select
Application.CutCopyMode = False
DLDataSht.Range(Cells(1, 1), Cells(LR, LC)).Copy
Wkb_1.Activate
Osht.Select
Osht.Range("A1").PasteSpecial
Application.CutCopyMode = False
' Osht.Range("O:O").EntireColumn.Delete
Osht.Range("R:V").EntireColumn.Delete
Osht.Range("C:C").EntireColumn.Delete
Osht.Columns("F:F").Insert Shift:=xlToRight
Osht.Range("F1") = "Section"
Osht.Range("F2:F" & LR).Formula = "=VLOOKUP(G2,Mapping!A:B,2,0)"
Osht.Columns("J:J").Insert Shift:=xlToRight
Osht.Range("J1") = "Expense G/L"
Osht.Range("J2:J" & LR).Formula = "=VLOOKUP(G2,Mapping!A:B,2,0)"
Osht.Columns("P:V").Insert Shift:=xlToRight
Osht.Range("P1") = "Vendor Code"
Osht.Range("P2:P" & LR).Formula = "=VLOOKUP(G2,YFIINTDSRP!H:J,3,0)"
Osht.Range("Q1") = "Vendor Name"
Osht.Range("Q2:Q" & LR).Formula = "=VLOOKUP(G2,YFIINTDSRP!H:K,4,0)"
Osht.Range("R1") = "Vendor PAN"
Osht.Range("R2:R" & LR).Formula = "=VLOOKUP(G2,YFIINTDSRP!H:L,5,0)"
Osht.Range("T2:T" & LR).Formula = "=LEFT(S2,4)"
Osht.Range("U2:U" & LR).Formula = "=RIGHT(U2,1)"
Osht.Range("V1") = "WHT Base Amount"
Osht.Range("W1") = "Amount in local curre ncy As per GL"
Osht.Range("Y1") = "Return TDS"
Osht.Range("Z1") = "Return rateS"
Osht.Range("Z2:Z" & LR).Formula = "=Y2/W2*100"
Osht.Range("AA1") = "RPU Base"
Osht.Range("AA2:AA" & LR).Formula = "=-W2"
Osht.Range("AB1") = "RPU TDS"
Osht.Range("AB2:AB" & LR).Formula = "=-Y2"
'Osht.Range("R1") = "Vendor PAN"
'Osht.Range("R2:R" & LR).Formula = "=VLOOKUP(H2,YFIINTDSRP!H:L,5,0)"
Osht.Columns("A:A").Insert Shift:=xlToRight
Osht.Range("A1") = "Working Remark"
Osht.Range("AE1") = "Certifiacte"
Osht.Range("AF1") = "Reason"
Osht.Range("AG1") = "BSRCode"
Osht.Range("AH1") = "Tender Date"
Osht.Range("AI1") = "Challan Sn"
Osht.Range("AJ1") = "SN"
'-----------------------------------------------------------------
'//Creating Output file
Path = ThisWorkbook.Path
Dim OWkb As Workbook
Set OWkb = Workbooks.Add
File_Name = Autosht.Range("D8")
Wkb_1.Sheets("Output File").Copy OWkb.Sheets(OWkb.Sheets.Count)
OWkb.SaveAs Filename:=Path & "\" & File_Name, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
OWkb.Activate: OWkb.Sheets("Output File").Range("A1").Select: OWkb.Save: Windows(File_Name).Close
End Sub
Try the Cleaning process for each sheet.
From the Last Edited Column till the End column (Towards Right).Select and Delete all columns (Ctrl + '-')
From the Last Edited Row till the End Row (Towards Bottom).Select and Delete all rows (Ctrl + '-')
Regarding 'Macro file size': No answer for this other than to suggest:
Export the modules from the 'big' macro workbook
Create a brand new workbook
Import the files from step 1 into the new workbook.
The new workbook will be smaller. If it grows every time you run your code - then that's where you can start to figure out the problem. Run just parts of the code until you can detect what code is changing the file size.
Your next question is how to find slow or lengthy operations. This can be done with code like:
Dim timeDuration As Variant
Dim timeStart As Variant
Dim timeEnd As Varient
timeStart = Timer
'Call a function or subroutine
timeEnd = Timer
Debug.Print "<Method Name> duration: " & CStr(timeEnd - timeStart)
Evaluate the results in the Immediate window
Or, you can put the code within each method and grab timeStart at the top of the method and timeEnd at the bottom.
It is helpful here is to have code that is grouped into focused methods that the above code can surround. The provided code has 4 methods...so that would be the first set of results to look at - and then proceed from there.
Evaluating the code was harder than it needed to be due to coding style. Some suggestions for you to consider:
Option Explicit
There are few VBA guidelines that fall under the category of always, but this is one of them:
Always declare Option Explicit at the top of any module you create in VBA. Option Explicit forces the developer to explicitly declare all variables, constants, and fields before using them within a module.
Declaring Option Explicit at the top of the provided code and invoking 'Debug -> Compile VBA Project' will identify 44 local variables that are used, but never declared and two subroutines that prevent the posted code from compiling (I assume the subroutines exist in another module...just not the one posted).
(Suggestion) The Visual Basice Editor (VBE) will automatically place Option Explicit at the top of new modules by checking 'Tools -> Options... -> Require Variable Declaration'.
Use Meaningful Names
All developers spend far more time reading code that writing it. Consequently, it is exceedingly important that code has variable names that are easily interpreted as to content and functionality. While actively writing code, it is easy to know/remember what variables like LR and/or LC mean. Step away from the code for 24 hours (or read it for the first time on an SO question)...and it's not.
The standard joke is: There are 2 hard problems in computer science: cache invalidation, naming things, and off-by-1 errors. That 'naming things' makes the list underscores both its importance (and difficulty). Long names will not slow down your code...use longer/descriptive names to make your life easier.
(Suggestion)Use names that are at least three characters but preferably full words that convey some meaning. Consider the name from the perspective of a first-time reviewer.
Manage variable Scope
This is related to using Option Explicit. There are 3 variable scopes in VBA: Global, Module, and Local. Some variables names in this code are repeated/used in several subroutines. These variables should be declared explicitly at the top of the module (Module Scope).
Look at how variable Wkb_1 is used. It is declared in Macro_Step_1 but used (without a declaration) in the next 3 subroutines. It is a Workbook object in the Macro_Step_1 (by declaration), but is a Variant in all subsequent uses because it is not explicitly declared. Further, it is assigned the Global ThisWorkbook object. ThisWorkbook should be used directly and Wkb_1 can be deleted. And, relating back to 'Use Meaningful Names', using Wkb_1 obscures the fact (further down the procedure) that it represents the ThisWorkbook object. wkbpath = ThisWorkbook.Path is much more clear than wkbpath = Wkb_1.Path.
(Suggestion) Review all your variables' scope and declare them in the appropriate locations.
Don't Repeat Yourself (DRY)
If you find yourself with a workflow of 'Copy - Paste - change a string', it is time to consider how to capture the code in a procedure. This will make your code easier to read, understand, and sometimes...faster depending on the operations involved.
The code
Tempsht.Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Was created using the above workflow 6 times. The entire wall of copied code can be replaced with:
GiveThisOperationAName "D", "F", "J", "M", "Q", "U"
Where GiveThisOperationAName is:
Private Sub GiveThisOperationAName(ParamArray columnLetters() As Variant)
Dim tempWorksheet As Worksheet
Set tempWorksheet = ThisWorkbook.Sheets("Temp")
Dim columnLetter As Variant
For Each columnLetter In columnLetters
tempWorksheet.Columns(columnLetter & ":" & columnLetter).TextToColumns _
Destination:=Range(columnLetter & "1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Next
End Sub
(Suggestion) There are other areas of opportunity like this. Removing duplication will make your code easier to read/understand, easier to maintain/modify, and easier to instrument for performance testing.
My Excel VBA script pulls data from other files, and my script isn't very good. How can I speed the file up?
So I pull 11x2737 data from each of 8 text files and pull 3x70101 from each of another 8 text files. It takes over 2 minutes to do this.
Set conFolder = CreateObject("Scripting.FileSystemObject")
For Each conFile In conFolder.GetFolder(folderName).Files
If InStr(conFile, "con.dat") > 0 Then
Set WorkB4 = Workbooks.Open(Filename:=conFile)
WorkB4.Activate
WorkB4.Application.DisplayAlerts = False
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), _
TrailingMinusNumbers:=True
Cells.Select
Selection.Copy
conBottle = Left(Right(conFile, 9), 1)
WorkB1.Activate
Sheets("Bot" & conBottle).Select
Range("A1").Select
ActiveSheet.Paste
WorkB4.Application.DisplayAlerts = True
WorkB4.Application.CutCopyMode = False
WorkB4.Close SaveChanges:=False
End If
Next
I'm hoping there's a way to pull this data as fast as possible (ideally within 5 seconds).
Avoiding Select and Activate, turning off ScreenUpdating, and skipping the clipboard should help, but typically the biggest bottleneck would be network or disk I/O: if the text files are on a network share, try copying them locally first.
So I refactored the code a bit, and there's only WorkB1 I couldn't work out where it came from.
None of this is tested, but it should give you a workable starting point.
Option Explicit
Public Sub ProcessFiles(ByVal Path As String)
Dim WorkB1 As Workbook ' <~
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo CleanFail
With CreateObject("Scripting.FileSystemObject")
Dim conFolder As Object
Set conFolder = .GetFolder(Path)
Dim conFile As Variant '/String
For Each conFile In conFolder.Files
If InStr(conFile, "con.dat", VbCompareMethod.vbTextCompare) > 0 Then
ProcessFile conFile, WorkB1
End If
Next
End With
CleanExit:
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
Debug.Print Err.Description
Resume CleanExit
End Sub
Private Sub ProcessFile(ByVal conFile As String, ByVal WorkB1 As Workbook)
On Error GoTo CleanFail
Dim book As Workbook
Set book = Workbooks.Open(conFile)
Dim sheet As Worksheet
Set sheet = book.Worksheets(1)
Dim dataRange As Range
Set dataRange = sheet.Columns(1)
Const NumberOfColumns As Long = 11
dataRange.TextToColumns _
destination:=sheet.Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlTextQualifierDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False, _
FieldInfo:=Array( _
Array(1, 1), _
Array(2, 1), _
Array(3, 1), _
Array(4, 1), _
Array(5, 1), _
Array(6, 1), _
Array(7, 1), _
Array(8, 1), _
Array(9, 1), _
Array(10, 1), _
Array(11, 1)), _
TrailingMinusNumbers:=True
Dim dataRows As Long
dataRows = sheet.Range("A" & sheet.Rows.Count).End(xlUp).Row
Dim sourceRange As Range
Set sourceRange = sheet.Range("A1", sheet.Cells(dataRows, NumberOfColumns))
Debug.Print "Source: " & sourceRange.Address(External:=True)
Dim conBotName As String
conBotName = Left$(Right$(conFile, 9), 1)
Dim conBotSheet As Worksheet
Set conBotSheet = WorkB1.Worksheets("Bot" & conBotName)
Dim destination As Range
Set destination = conBotSheet.Range("A1", conBotSheet.Cells(dataRows, NumberOfColumns))
Debug.Print "Destination: " & destination.Address(External:=True)
destination.Value = sourceRange.Value
book.Close SaveChanges:=False
CleanExit:
Exit Sub
CleanFail:
Debug.Print Err.Description
Resume CleanExit
End Sub
I currently have a macro set up that allows me to paste data into column A from Textpad and then sorts, rounds, moves and saves the data as a txt file.
Is there anyway that I can modify the macro to allow me to import the txt file straight into Excel rather than having to copy and paste? The file names changes each time, but the file directory will stay the same.
This is the current macro I have that is run after manually copy and pasting the data into excel:
'Sub SortRoundandSave()
'
' SortTruncateandSave Macro
' This macro will sort, round and save your data
'
'
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
Range("D1").Select
Selection.AutoFill Destination:=Range("D1:D" & Range("B" & Rows.Count).End(xlUp).Row)
Range("A:A,B:B,D:D").Select
Range("D1").Activate
Selection.Copy
Sheets("Truncated Data").Select
ActiveSheet.Paste
Sheets("Truncated Data").Select
Application.CutCopyMode = False
Sheets("Truncated Data").Move
ChDir "G:\XXXX\Folder\Name\ZZZZ\Sort"
ActiveWorkbook.SaveAs Filename:= _
"G:\XXXX\Folder\Name\ZZZZ\Sort\Sorted Data.txt", _
FileFormat:=xlText, CreateBackup:=False
Windows("Excel Truncator.xlsm").Activate
End Sub
I assume it needs a few lines before the text to columns part, but I cant seem to get one to work?
Any help would be greatly appreciated.
Thanks
Try this:
Sub SortRoundandSave()
'
' SortTruncateandSave Macro
' This macro will sort, round and save your data
'
Dim workSht As Worksheet: Set workSht = ActiveSheet 'ThisWorkbook.Sheets("") ' Enter the name of sheet
Dim FilePath As String
Dim strLine As String
Dim rowCnt As Long
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select the file"
.Filters.Clear
.Filters.Add Description:="Text Files", Extensions:="*.txt"
'.InitialFileName = "G:\XXXX\Folder\Name" ' Optional: this is a startup directory, place the correct one and uncomment line
If .Show = 0 Then Exit Sub
FilePath = .SelectedItems(1)
End With
rowCnt = 1
Open FilePath For Input As #1
Do While Not EOF(1)
Line Input #1, strLine
workSht.Cells(rowCnt, 1) = strLine
rowCnt = rowCnt + 1
Loop
Close #1
With workSht
Range(.Cells(1, 1), .Cells(rowCnt - 1, 1)).TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
.Cells(1, 4).AutoFill Destination:=Range(.Cells(1, 4), .Cells(workSht.Cells(Rows.Count, 2).End(xlUp).Row, 4)) ' "D1:D" & Range("B" & Rows.Count).End(xlUp).Row)
Range(.Cells(1, 1), .Cells(1, 4)).EntireColumn.Copy Sheets("Truncated Data").Cells(1, 1)
End With
Sheets("Truncated Data").Move
ActiveWorkbook.SaveAs Filename:= _
"G:\XXXX\Folder\Name\ZZZZ\Sort\Sorted Data.txt", _
FileFormat:=xlText, CreateBackup:=False
workSht.Parent.Activate
End Sub
I have 3 csv files which I have to merge and but before that I have to prepare then to have same columns order. All works fine except for I cannot figure out so far how change order of columns in output file. I can select columns which I want and other skips fine but what if I want to swap some? I thought that putting in proper order in fieldinfo array would do the trick but no. I want to swap 8 with 6.
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=Filenamenew, Origin:=xlWindows, StartRow _
:=2, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
Space:=False, Other:=False, FieldInfo:=Array(Array(1, 3), Array(2, 9), Array(3, 1), Array(4, 9), Array(5, 9), Array(8, 1), Array(7, 9), Array(6, 1))
Set Wb = ActiveWorkbook
Application.DisplayAlerts = False
Wb.SaveAs Filename:=LBname, FileFormat:=FileFormatNum, _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
Wb.Close savechanges:=False
thanks
The best way to do this is to change the output of whatever is creating the CSV file you need to change. I assume you don't have access to that for whatever reason, so this will get the job done:
Sub swapColumns(first As Integer, second As Integer)
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks.Open("C:\root\test.csv")
Set ws = wb.Sheets(1)
If first > second Then
Dim i As Integer
i = first
first = second
second = i
ElseIf first = second Then
Exit Sub
End If
ws.Columns(second).Cut
ws.Columns(first).Insert Shift:=xlToRight
ws.Columns(first + 1).Cut
ws.Columns(second + 1).Insert Shift:=xlToRight
End Sub
You can call this Sub from your existing code with swapColumns 6, 8