I have a following macro which used to open all files based on the value in the cell reference. I am not sure why the below macro is not working.
Sub Macro1()
Dim wb As Workbook
Dim UserSelectedFile As Variant
Dim strFolder As String
Dim strFile As String
strFolder = Sheets("Snapshot").Range("a12").Value
strFile = Dir(strFolder & "*.xlsm*")
Do While strFile <> ""
Set wb = Workbooks.Open(strFolder & strFile)
strFile = Dir
Loop
End Sub
I need to open all the .xlsm files in readonly mode based on link given in cell A12.
Just a string missing in your declaration.
Sub MacroTest()
Dim wb As Workbook
Dim FileName As String
Dim UserSelectedFile As Variant
Dim strFolder As String
Dim strFile As String
FileName = Sheets("Snapshot").Range("A12").Value
strFile = Dir(strFolder & "*.xlsm*")
Do While strFile <> ""
Set wb = Workbooks.Open(strFolder & strFile, ReadOnly:=True)
strFile = Dir
DoEvents
Loop
End Sub
Related
I have a code to insert all data from different excel files located in one folder as a loop ,
but the inserted data comes as a table (Vertically) , here is my question
what is the required modification to the existing code to make the inserted data transpose horizontally??????? thanks in advance
here is the pic of loaded data, i need these table to be shown horizontally
enter image description here
here is my code
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\Users\mjamal\Desktop\Downloads\Sensor1"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 1
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set BaseWks = Worksheets("Sheet1")
rnum = 5
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("B1:BB7")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "C"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("G" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount + 5
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
I have some code which reads in a tab delimited file where cell reference B2 matches the reference in the first column in the tab delimited file. This works fine where the text file is small. The below works on a sample file with aa bb and cc as the headers with dummy data.
Option Explicit
Sub TestImport()
Call ImportTextFile(Sheet1.Range("B1"), vbTab, Sheet2.Range("A4"))
End Sub
Public Sub ImportTextFile(strFileName As String, strSeparator As String, rngTgt As Range)
Dim lngTgtRow As Long
Dim lngTgtCol As Long
Dim varTemp As Variant
Dim strWholeLine As String
Dim intPos As Integer
Dim intNextPos As Integer
Dim intTgtColIndex As Integer
Dim wks As Worksheet
Set wks = rngTgt.Parent
intTgtColIndex = rngTgt.Column
lngTgtRow = rngTgt.Row
Open strFileName For Input Access Read As #1
While Not EOF(1)
Line Input #1, strWholeLine
varTemp = Split(strWholeLine, strSeparator)
If CStr(varTemp(0)) = CStr(Range("B2")) Then
wks.Cells(lngTgtRow, intTgtColIndex).Resize(, UBound(varTemp) + 1).Value = varTemp
lngTgtRow = lngTgtRow + 1
End If
Wend
Close #1
Set wks = Nothing
End Sub
I am trying to get the below bit of code to work using ADO as this will run much faster on a text file with a couple of million records however I am getting an error on the '.Open str' part of the code (no value given for one or more required parameters).
It looks like it is to do with how I am defining the string- could you review and see if there is something I am missing...?
Sub QueryTextFile()
t = Timer
Dim cnn As Object
Dim str As String
Set cnn = CreateObject("ADODB.Connection")
cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
cnn.ConnectionString = "Data Source=C:\Users\Davids Laptop\Documents\Other Ad Hoc\Test Files\;Extended Properties=""text;HDR=Yes;FMT=Delimited;"""
cnn.Open
Dim rs As Object
Set rs = CreateObject("ADODB.Recordset")
str = "SELECT * FROM [test1.txt] WHERE [aa]=" & Chr(34) & Range("B2") & Chr(34)
With rs
.ActiveConnection = cnn
.Open str
Sheet1.Range("A4").CopyFromRecordset rs
.Close
End With
cnn.Close
MsgBox Timer - t
End Sub
I have the following scenario:
I have thousands of text files with the below format.The column names are written in separate lines where as the row values are delimited by Pipe(|).
START-OF-FILE
PROGRAMNAME=getdata
DATEFORMAT=yyyymmdd
#Some Text
#Some Text
#Some Text
#Some Text
#Some Text
START-OF-FIELDS
Field1
Field2
Field3
------
FieldN
END-OF-FIELDS
TIMESTARTED=Tue May 12 16:04:42 JST 2015
START-OF-DATA
Field1Value|Field2value|Field3Value|...|Field N Value
Field1Value|Field2value|Field3Value|...|Field N Value
------|...........|----|-------
END-OF-DATA
DATARECORDS=30747
TIMEFINISHED=Tue May 12 16:11:53 JST 2015
END-OF-FILE
Now I have a corresponding SQL Server table, where I can easily load the data as destination.
Since I am new to SSIS, having trouble as to how to write the Script Component so that I can filter the Source Text files and easily load into sql server table.
Thanks in advance!
There are a few ways to do it. If the format of the files are constant, there are some useful properties of the flat file connection manager editor. For example, you can add a new flat file connection into the connection managers. There are some properties such as "Rows to skip" for the above file, you could set this to 18. Then it would start at the columns line with the "|".
Another property of the flat file connection manager that may be useful is that if you open the flat file connection manager, and then click on columns in the side menu, you can set the column delimter to the pipe "|"
But if the format of the file will change, e.g. variable number of header rows, you can use a script task to remove any non-piped rows. e.g. the header and footer.
For example, you can add a method such as file.readalllines and then edit or remove the lines as needed then save the file.
Info about that method is here:
https://msdn.microsoft.com/en-us/library/s2tte0y1%28v=vs.110%29.aspx
e.g. to remove last line in script task
string[] lines = File.ReadAllLines( "input.txt" );
StringBuilder sb = new StringBuilder();
int count = lines.Length - 1; // all except last line
for (int i = 0; i < count; i++)
{
sb.AppendLine(lines[i]);
}
File.WriteAllText("output.txt", sb.ToString());
USE Below VB Script in your SSIS SCript Component Task as source
enter code here
Imports System
Imports System.Data
Imports System.Math
Imports System.IO
Imports Microsoft.SqlServer.Dts.Runtime
Imports Microsoft.SqlServer.Dts.Pipeline.Wrapper
Imports Microsoft.SqlServer.Dts.Runtime.Wrapper
<Microsoft.SqlServer.Dts.Pipeline.SSISScriptComponentEntryPointAttribute()> _
<CLSCompliant(False)> _
Public Class ScriptMain
Inherits UserComponent
'Private strSourceDirectory As String
'Private strSourceFileName As String
Private strSourceSystem As String
Private strSourceSubSystem As String
Private dtBusinessDate As Date
Public Overrides Sub PreExecute()
MyBase.PreExecute()
'
' Add your code here for preprocessing or remove if not needed
''
End Sub
Public Overrides Sub PostExecute()
MyBase.PostExecute()
'
' Add your code here for postprocessing or remove if not needed
' You can set read/write variables here, for example:
Dim strSourceDirectory As String = Me.Variables.GLOBALSourceDirectory.ToString()
Dim strSourceFileName As String = Me.Variables.GLOBALSourceFileName.ToString()
'Dim strSourceSystem As String = Me.Variables.GLOBALSourceSystem.ToString()
'Dim strSourceSubSystem As String = Me.Variables.GLOBALSourceSubSystem.ToString()
'Dim dtBusinessDate As Date = Me.Variables.GLOBALBusinessDate.Date
End Sub
Public Overrides Sub CreateNewOutputRows()
'
' Add rows by calling the AddRow method on the member variable named "<Output Name>Buffer".
' For example, call MyOutputBuffer.AddRow() if your output was named "MyOutput".
'
Dim sr As System.IO.StreamReader
Dim strSourceDirectory As String = Me.Variables.GLOBALSourceDirectory.ToString()
Dim strSourceFileName As String = Me.Variables.GLOBALSourceFileName.ToString()
'Dim strSourceSystem As String = Me.Variables.GLOBALSourceSystem.ToString()
'Dim strSourceSubSystem As String = Me.Variables.GLOBALSourceSubSystem.ToString()
'Dim dtBusinessDate As Date = Me.Variables.GLOBALBusinessDate.Date
'sr = New System.IO.StreamReader("C:\QRM_SourceFiles\BBG_BONDS_OUTPUT_YYYYMMDD.txt")
sr = New System.IO.StreamReader(strSourceDirectory & strSourceFileName)
Dim lineIndex As Integer = 0
While (Not sr.EndOfStream)
Dim line As String = sr.ReadLine()
If (lineIndex <> 0) Then 'remove header row
Dim columnArray As String() = line.Split(Convert.ToChar("|"))
If (columnArray.Length > 1) Then
Output0Buffer.AddRow()
Output0Buffer.Col0 = columnArray(0).ToString()
Output0Buffer.Col3 = columnArray(3).ToString()
Output0Buffer.Col4 = columnArray(4).ToString()
Output0Buffer.Col5 = columnArray(5).ToString()
Output0Buffer.Col6 = columnArray(6).ToString()
Output0Buffer.Col7 = columnArray(7).ToString()
Output0Buffer.Col8 = columnArray(8).ToString()
Output0Buffer.Col9 = columnArray(9).ToString()
Output0Buffer.Col10 = columnArray(10).ToString()
Output0Buffer.Col11 = columnArray(11).ToString()
Output0Buffer.Col12 = columnArray(12).ToString()
Output0Buffer.Col13 = columnArray(13).ToString()
Output0Buffer.Col14 = columnArray(14).ToString()
Output0Buffer.Col15 = columnArray(15).ToString()
Output0Buffer.Col16 = columnArray(16).ToString()
Output0Buffer.Col17 = columnArray(17).ToString()
Output0Buffer.Col18 = columnArray(18).ToString()
Output0Buffer.Col19 = columnArray(19).ToString()
Output0Buffer.Col20 = columnArray(20).ToString()
Output0Buffer.Col21 = columnArray(21).ToString()
Output0Buffer.Col22 = columnArray(22).ToString()
Output0Buffer.Col23 = columnArray(23).ToString()
Output0Buffer.Col24 = columnArray(24).ToString()
End If
End If
lineIndex = lineIndex + 1
End While
sr.Close()
End Sub
End Class
Code End
In a sample.csv file, which has fixed number of columns, I have to extract a particular field value and store it in a variable using VBScript.
sample.csv
100,SN,100.SN,"100|SN| 435623| serkasg| 15.32|
100|SN| 435624| serkasg| 15.353|
100|SN| 437825| serkasg| 15.353|"," 0 2345"
101,SN,100.SN,"100|SN| 435623| serkasg| 15.32|
100|SN| 435624| serkasg| 15.353|
100|SN| 437825| serkasg| 15.353|"," 0 2346"
I want to parse the last two fields which are within double quotes and store them in two different array variables for each row.
You could try using an ADO connection
Option Explicit
dim ado: set ado = CreateObject("ADODB.Connection")
ado.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties=""text;HDR=No;FMT=Delimited"";"
ado.open
dim recordSet: set recordSet = ado.Execute("SELECT * FROM [samples.csv]")
dim field3, field4
do until recordSet.EOF
field3 = recordSet.Fields(3).Value
field4 = recordSet.Fields(4).Value
' use your fields here
recordSet.MoveNext
loop
recordSet.close
ado.close
You may have an issue if those fields are greater than 255 characters in length - if they are, they may return truncated. You also may have better luck with ODBC or ACE connection strings instead of the Jet one I've used here.
Since CSV's are comma-separated, you can use the Split() function to separate the fields into an array:
' Read a line from the CSV...
strLine = myCSV.ReadLine()
' Split by comma into an array...
a = Split(strLine, ",")
Since you have a static number of columns (5), the last field will always be a(4) and the second-to-last field will be a(3).
Your CSV data seems to contain 2 embedded hard returns (CR, LF) per line. Then the first line ReadLine returns is:
100,SN,100.SN,"100|SN| 435623| serkasg| 15.32|
The solution below unwraps these lines before extracting the required fields.
Option Explicit
Const ForReading = 1
Const ForAppending = 8
Const TristateUseDefault = 2 ' Opens the file using the system default.
Const TristateTrue = 1 ' Opens the file as Unicode.
Const TristateFalse = 0 ' Opens the file as ASCII.
Dim FSO, TextStream, Line, LineNo, Fields, Field4, Field5
ExtractFields "sample.csv"
Sub ExtractFields(FileName)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(FileName) Then
Line = ""
LineNo = 0
Set TextStream = FSO.OpenTextFile(FileName, ForReading, False, TristateFalse)
Do While Not TextStream.AtEndOfStream
Line = Line & TextStream.ReadLine()
LineNo = LineNo + 1
If LineNo mod 3 = 0 Then
Fields = Split(Line, ",")
Field4 = Fields(3)
Field5 = Fields(4)
MsgBox "Line " & LineNo / 3 & ": " & vbNewLine & vbNewLine _
& "Field4: " & Field4 & vbNewLine & vbNewLine _
& "Field5: " & Field5
Line = ""
End If
Loop
TextStream.Close()
Else
MsgBox "File " & FileName & " ... Not found"
End If
End Sub
Here is an alternative solution that allows for single or multiline CSV records. It uses a regular expression which simplifies the logic for handling multiline records. This solution does not remove CRLF characters embedded in a record; I've left that as an exercise for you :)
Option Explicit
Const ForReading = 1
Const ForAppending = 8
Const TristateUseDefault = 2 ' Opens the file using the system default.
Const TristateTrue = 1 ' Opens the file as Unicode.
Const TristateFalse = 0 ' Opens the file as ASCII.
Dim FSO, TextStream, Text, MyRegExp, MyMatches, MyMatch, Field4, Field5
ExtractFields "sample.csv"
Sub ExtractFields(FileName)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(FileName) Then
Set MyRegExp = New RegExp
MyRegExp.Multiline = True
MyRegExp.Global = True
MyRegExp.Pattern = """([^""]+)"",""([^""]+)"""
Set TextStream = FSO.OpenTextFile(FileName, ForReading, False, TristateFalse)
Text = TextStream.ReadAll
Set MyMatches = MyRegExp.Execute(Text)
For Each MyMatch in MyMatches
Field4 = SubMatches(0)
Field5 = SubMatches(1)
MsgBox "Field4: " & vbNewLine & Field4 & vbNewLine & vbNewLine _
& "Field5: " & vbNewLine & Field5, 0, "Found Match"
Next
Set MyMatches = Nothing
TextStream.Close()
Else
MsgBox "File " & FileName & " ... Not found"
End If
End Sub
Currently, the folder I'm importing from has 16,000 files and I only need the latest ones. The amount of lines wouldn't be so bad if it didn't break Excel every time it tried to run. The code I'm using imports them all:
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("X:\TMS\TRUCK_OUT")
' set the starting point to write the data to
Set cl = ActiveSheet.Cells(1, 1)
' Loop thru all files in the folder
For Each file In folder.Files
' Open the file
Set FileText = file.OpenAsTextStream(ForReading)
' Read the file one line at a time
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine
' Parse the line into | delimited pieces
Items = Split(TextLine, "|")
' Put data on one row in active sheet
For i = 0 To UBound(Items)
cl.Offset(0, i).Value = Items(i)
Next
' Move to next row
Set cl = cl.Offset(1, 0)
Loop
' Clean up
FileText.Close
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
Check out the following code - I have commented the extra line of code that i have added
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
Dim fileModDate As Date 'PANKAJ - Added the variable
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("C:\Users\pankaj.jaju\Desktop")
' set the starting point to write the data to
Set cl = ActiveSheet.Cells(1, 1)
' Loop thru all files in the folder
For Each file In folder.Files
fileModDate = file.DateLastModified 'PANKAJ - Added this to get the last modified date for each file
If fileModDate > #1/20/2014 1:00:00 PM# Then 'PANKAJ - Added this to get the desired file based on modified date
' Open the file
Set FileText = file.OpenAsTextStream(ForReading)
' Read the file one line at a time
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine
' Parse the line into | delimited pieces
Items = Split(TextLine, "|")
' Put data on one row in active sheet
For i = 0 To UBound(Items)
cl.Offset(0, i).Value = Items(i)
Next
' Move to next row
Set cl = cl.Offset(1, 0)
' Clean up
FileText.Close
Loop
End If
Next
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub