I have an Excel worksheet with around 100 cols. Does anyone know of an easy way to write the contents of each column to a csv or txt file?
I don't have Excel in front of me, but I think this code is approximately what you need, give or take some syntax errors. It should write each column into a separate file, with each cell on a different row. It will work for arbitrary column heights, though the number of columns is in a variable (for now).
dim fso as FileSystemObject
dim ts as TextStream
dim i as Integer
dim myCell as Range
set fso = FileSystemObject
for i = 0 to TotalColumnNumber
' last argument, True, says to create the text file if it doesnt exist, which is
' good for us in this case
Set ts = fso.OpenTextFile("column_" & i, ForWriting, True)
' set mycell to the first cell in the ith column
set myCell = SheetName.cells(1,i)
' continue looping down the column until you reach a blank cell
' writing each cell value as you go
do until mycell.value = ""
ts.writeline mycell.value
set myCell = myCell.offset(1,0)
loop
ts.close
next
set ts = nothing
set fso = nothing
Let me know if that helps or not, I can take another look later if you would like
Perhaps
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim i As Integer
''This is not the best way to refer to the workbook
''you want, but it is very conveient for notes
''It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''WHERE 1=1 = headers only, note hdr=yes above
strSQL = "SELECT * " _
& "FROM [Sheet1$] " _
& "WHERE 1=1"
''Open the recordset for more processing
''Cursor Type: 3, adOpenStatic
''Lock Type: 3, adLockOptimistic
''Not everything can be done with every cirsor type and
''lock type. See http://www.w3schools.com/ado/met_rs_open.asp
rs.Open strSQL, cn, 3, 3
''Output including nulls. Note that this will fail if the file
''exists.
For i = 0 To rs.Fields.Count - 1
strSQL = "SELECT [" & rs.Fields(i).Name & "] " _
& "INTO [Text;HDR=YES;FMT=Delimited;IMEX=2;DATABASE=C:\Docs\]." _
& rs.Fields(i).Name & ".CSV " _
& "FROM [Sheet1$] "
''To skip nulls and empty cells, add a WHERE statement
''& "WHERE Trim([" & rs.Fields(i).Name & "] & '')<>'' "
cn.Execute strSQL
Next
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
A very quick line to get you started ...
for i = 1 to 100
open "file" & i & ".txt" as #1
for each c in columns(i).cells
print #1, c.value
next c
close #1
next i
Related
Example data
Dim strFileName As String
strFileName = "Acquired last 30 days.xlsx"
Dim lDays As Long
lDays = 2
Dim chkDate As Date
chkDate = Date - lDays
Dim cn As Object, cmd As Object, rs As Object
'---Connecting to the Data Source---
Set cn = CreateObject("ADODB.Connection")
Set cmd = CreateObject("ADODB.Command")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & strFileName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
.Open
End With
' Assemble paramaters and run
With cmd
.ActiveConnection = cn
.CommandType = 1
.CommandText = "SELECT [F1],[F3],[F4] FROM [Sheet 1$] WHERE F4>?"
.Parameters.Append .CreateParameter("pDate4", 7, 1, 30, chkDate)
Set rs = .Execute
End With
If Not rs.EOF Then
Do
Debug.Print rs(0) & "-" & rs(1) & "-" & rs(2)
rs.Movenext
Loop Until rs.EOF
End If
I've tried with and without parameters, with and without #, with and without BETWEEN, with and without using the same date format, with and without CDate() in the the where and select clauses (get an invalue Null error in the where clause - likely because of the blank lines at the top of the table). My basic test results return all the values or none of the values. Some examples:
All values including header:
"SELECT [F1],[F3],[F4] FROM [Sheet 1$] WHERE F4>#2018/01/05#"
"SELECT [F1],[F3],[F4] FROM [Sheet 1$] WHERE F4>#01/05/2018#"
Just header:
"SELECT [F1],[F3],[F4] FROM [Sheet 1$] WHERE F4>#05/01/2018#"
Nothing:
"SELECT [F1],[F3],[F4] FROM [Sheet 1$] WHERE F4 BETWEEN #01/01/2019# AND #01/01/2021#"
The data starts around row 15, and the date in the column 4 is stored as a date in Excel but formatted dd-mmm-yyyy. I'd like to avoid opening the file and reformatting it.
I'm at a loss. The only thing I can think of is to pull all the data and then evaluate it line by line in the recordset before writing, but I'd REALLY like to avoid that as well.
What am I doing wrong????
This worked for me:
With cmd
.ActiveConnection = cn
.CommandType = 1
.CommandText = "SELECT [F1],[F3],[F4] FROM [Sheet1$] WHERE F4 > ?"
.Parameters.Append .CreateParameter("pDate4", 5, 1, 30, CLng(chkDate)) '5=adDouble
Set rs = .Execute
End With
If Not rs.EOF Then
Do
Debug.Print rs(0) & "-" & rs(1) & "-" & Format(rs(2).Value, "mm/dd/yyyy")
rs.Movenext
Loop Until rs.EOF
End If
It's not what I was looking for, but this was the only thing I could get to work.
I ended up writing a loop to put together the strings so that they match the results I was seeing from the recordset. (The column names are slightly different as I paired back the table for my original question, but you get the idea.)
Dim i As Long
lDays = lDays - 1
Dim strDate As String
For i = 0 To lDays
strDate = CStr(Format(Date - i, "dd-mmm-yyyy"))
strTemp = AHK_Append(strTemp, "F9='" & strDate & "' OR F15='" & strDate, "' OR ")
Next
strTemp = " WHERE F8='Acquired' AND (" & strTemp & "')"
I really wish there was a way to convert a value prior to evaluating it in the WHERE clause, but I'm moving on.
The routine below reads in a csv file using ADO. The csv file I am reading has 139,000 lines of data, with 136 columns. The routine is not working as intended. One of the columns has zero values for all rows except for 500 or so rows, where it takes a decimal value of, say, 0.05 or 0.03 etc. Because this method uses ADO, it determines the data type of the field using a setting in the registry, TypeGuessRows, where, based on a pre-specfied number of rows, it makes a guess at the data type of that column. So, for the column in the example, it is, I think, assuming an integer data type because the first couple of hundred values are all zero. The few values that are decimal and non-zero are then forced to fit the assumed data type and therefore also become zero. I cannot change the value of TypeGuessRows because, in the company I work for, I do not have permissions to change the registry. Of the 136 columns, there are many other columns with a similar problem.
Is there a way around this? I have seen a suggestion that I could use a dummy first row with the value that will imply the desired data type, but this is an overhead I would rather not incur.
Or do I simply need to use a method of data import that does not use ADO?
Sub GetDataTextFile1(strFilePath As String, strSheet As String, strRange As String, strField As String, strValue As String)
Dim strFolder As String, strFile As String, strSQL As String
Dim objConnection As ADODB.Connection
Dim objRecordSet As ADODB.Recordset
'If an error occurs then handle it
'On Error GoTo ErrorTrap
'Get the name of the file and the folder
strFile = Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, "\"))
strFolder = Left(strFilePath, Len(strFilePath) - Len(strFile) - 1)
Set objConnection = New ADODB.Connection
Set objRecordSet = New ADODB.Recordset
'Open Connection
objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source=" & strFolder & ";" _
& "Extended Properties=""text;HDR=YES;FMT=Delimited"""
'Generate SQL code to extract data from the file
If strField <> "" And strValue <> "" Then
strSQL = "SELECT * FROM [" & strFile & "] WHERE CSTR([" & strField & "]) IN ('" & strValue & "');"
Else
strSQL = "SELECT * FROM [" & strFile & "];"
End If
'Execute the SQL code
Set objRecordSet = objConnection.Execute(strSQL)
'Copy the data in to the relevant range in the spreadsheet
ThisWorkbook.Sheets(strSheet).Range(strRange).CopyFromRecordset objRecordSet
'Close the recordset and the connection to the database
objRecordSet.Close
objConnection.Close
Set objRecordSet = Nothing
Set objConnection = Nothing
ExitPoint:
Exit Sub
ErrorTrap:
Call ErrorHandler(Err.Number, Err.Description, "GetDataTextFile1")
End Sub
Replace the line
ThisWorkbook.Sheets(strSheet).Range(strRange).CopyFromRecordset objRecordSet
With the following
Dim r as range
Dim f as field
dim x as long
Set r = ThisWorkbook.Sheets(strSheet).Range(strRange)
Do while not objrecordset.eof
x = 0
For each f in objrecordset.fields
r.offset(0,x) = objrecordset(x)
x = x +1
next f
objrecordset.movenext
set r = r.offset(1,0)
loop
This will bring the data in bit by bit. If that isn't sufficient to avoid it guessing the datatype you can add a select case f.name routine to force the datatype of certain fields
You can import your CSV, and even multiple CSV files, using the script below.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim i As Long
Dim cl As Range
Set fso = New FileSystemObject
Set folder = fso.GetFolder("C:\Users\Excel\Desktop\test\")
Set cl = ActiveSheet.Cells(1, 1)
Application.ScreenUpdating = False
For Each file In folder.Files
Set FileText = file.OpenAsTextStream(ForReading)
cl.Value = file.Name
i = 1
Do While Not FileText.AtEndOfStream
cl.Offset(i, 0).Value = FileText.ReadLine
i = i + 1
Loop
FileText.Close
Set cl = cl.Offset(0, 1)
Next file
Application.ScreenUpdating = True
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
The current codes I am working on requires me to rearrange the columns in VBA. It has to arranged according to the header, and the headers are "V-d(1)", "V-g(1)", "I-d(1)", "I-g(1)", and this set repeats for numbers 2, 3, etc etc. (e.g V-d(2), I-g(4)). These data are usually jumbled up and I have to arrange them in ascending numbers.
It does not matter if V-g, V-d, I-d or I-g comes first.
Dim num, numadj As Integer
Dim colu, coladj
Range("A1").Select
Do While Range("A1").Offset(0, i - 1).Value <> ""
colu = ActiveCell.Value
coladj = ActiveCell.Offset(0, 1).Value
num = Left(Right(colu.Text, 2), 1)
numadj = Left(Right(coladj.Text, 2), 1)
If num > numadj Then
colu.EntireColumn.Cut Destination:=Columns("Z:Z")
coladj.EntireColumn.Cut Destination:=colu
Columns("Z:Z").Select.Cut Destination:=coladj
i = i + 1
Else
i = i + 1
End If
Loop
I am very new to VBA so please forgive me for any dumb codes that I have created!!! Thank you in advance everyone!
Consider an SQL and RegEx solution to select columns in a specified arrangement. SQL works in Excel for PC which can access Windows' Jet/ACE SQL Engine to query its own workbook like a database table.
Due to the variable nature of sets ranging 3-10, consider finding the highest number set by extracting the numbers from column headers with RegEx using the defined function, FindHighestNumberSet. Then have RunSQL subroutine call the function to build SQL string dynamically.
Below assumes you have data currently in a tab named DATA with an empty tab named RESULTS which will output query results. Two ADO connection strings are available.
Function (iterating across column headers to extract highest number)
Function FindHighestNumberSet() As Integer
Dim lastcol As Integer, i As Integer
Dim num As Integer: num = 0
Dim regEx As Object
' CONFIGURE REGEX OBJECT
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "[^0-9]"
End With
With Worksheets("DATA")
lastcol = .Cells(7, .Columns.Count).End(xlToLeft).Column
For i = 1 To lastcol
' EXTRACT NUMBERS FROM COLUMN HEADERS
num = Application.WorksheetFunction.Max(num, CInt(regEx.Replace(.Cells(1, i), "")))
Next i
End With
FindHighestNumberSet = num
End Function
Macro (main module looping through result of above function)
Sub RunSQL()
On Error GoTo ErrHandle
Dim conn As Object, rst As Object
Dim strConnection As String, strSQL As String
Dim i As Integer
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' DRIVER AND PROVIDER CONNECTION STRINGS
' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "DBQ=" & Activeworkbook.FullName & ";"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='" & ActiveWorkbook.FullName & "';" _
& "Extended Properties=""Excel 8.0;HDR=YES;"";"
' FIRST THREE SETS
strSQL = " SELECT t.[V-d(1)], t.[I-d(1)], t.[I-g(1)]," _
& " t.[V-d(2)], t.[I-d(2)], t.[I-g(2)]," _
& " t.[V-d(3)], t.[I-d(3)], t.[I-g(3)]"
' VARIABLE 4+ SETS
For i = 4 To FindHighestNumberSet
strSQL = strSQL & ", t.[V-d(" & i & ")], t.[I-d(" & i & ")], t.[I-g(" & i & ")]"
Next i
' FROM CLAUSE
strSQL = strSQL & " FROM [DATA$] t"
' OPEN DB CONNECTION
conn.Open strConnection
rst.Open strSQL, conn
' COLUMN HEADERS
For i = 1 To rst.Fields.Count
Worksheets("RESULTS").Cells(1, i) = rst.Fields(i - 1).Name
Next i
' DATA ROWS
Worksheets("RESULTS").Range("A2").CopyFromRecordset rst
rst.Close: conn.Close
Set rst = Nothing: Set conn = Nothing
MsgBox "Successfully ran SQL query!", vbInformation
Exit Sub
ErrHandle:
Set rst = Nothing: Set conn = Nothing
MsgBox Err.Number & " = " & Err.Description, vbCritical
Exit Sub
End Sub
You can sort vertically by a helper row with something like this (tested):
Sub test() ': Cells.Delete: [b2:d8] = Split("V-d(10) V-d(2) V-d(1)") ' used for testing
Dim r As Range: Set r = ThisWorkbook.Worksheets("Sheet1").UsedRange ' specify the range to be sorted here
r.Rows(2).Insert xlShiftDown ' insert helper row to sort by. (used 2nd row instead 1st so that it is auto included in the range)
r.Rows(2).FormulaR1C1 = "=-RIGHT(R[-1]C,LEN(R[-1]C)-3)" ' to get the numbers from the column header cells above, so adjust if needed
r.Sort r.Rows(2) ' sort vertically by the helper row
r.Rows(2).Delete xlShiftUp ' delete the temp row
End Sub
I tried the code in this link to push and retrieved the data between Excel and Access. I modified the code based on my file path as following:
EDITED NEW CODE BLOCK
Sub UpdateMDB()
Dim accConn As Object, accRST As Object
Dim accFile As String, accStr As String
Dim lastrow As Long, i As Long
lastrow = Workbooks(1).Sheets(1).Cells(Workbooks(1).Sheets(1).Rows.Count, "A").End(xlUp).Row
accFile = "Z:\Documents\Database\Database1.mdb"
accStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & accFile & ";"
Set accConn = CreateObject("ADODB.Connection")
Set accRST = CreateObject("ADODB.Recordset")
accConn.Open accStr
accRST.Open "SELECT * FROM Table1", accConn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
If Not (accRST.BOF And accRST.EOF) Then
accRST.MoveFirst
Else
MsgBox "No records in Access table.", vbInformation
accRST.Close: accConn.Close: Set accRST = Nothing: Set accConn = Nothing
Exit Sub
End If
Do While Not accRST.EOF
For i = 1 To lastrow
If accRST!ID = Workbooks(1).Sheets(1).Range("A" & i) _
And accRST!Field1 <> Workbooks(1).Sheets(1).Range("B" & i) Then
accRST!Field1.Value = Workbooks(1).Sheets(1).Range("B" & i)
End If
Next i
accRST.Update
accRST.MoveNext
Loop
accRST.Close: accConn.Close
Set accRST = Nothing: Set accConn = Nothing
End Sub
INITIAL CODE BLOCK
Sub GetMDB()
Dim cn As Object
Dim rs As Object
strFile = "Z:\Documents\Database\Database1.mdb"
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile & ";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT * FROM Table1"
rs.Open strSQL, cn
With Worksheets(1)
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1) = rs.Fields(i).Name
Next
rs.MoveFirst
.Cells(2, 1).CopyFromRecordset rs
End With
End Sub
Sub UpdateMDB()
Dim cn As Object
Dim rs As Object
''It would probably be better to use the proper name, but this is
''convenient for notes
strFile = Workbooks(1).FullName
''Note HDR=Yes, so you can use the names in the first row of the set
''to refer to columns
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''Selecting the cell that are different
strSQL = "SELECT * FROM [Sheet1$] s " _
& "INNER JOIN [;Database=Z:\Documents\Database\Database1.mdb;].Table1 t " _
& "ON s.id=t.id " _
& "WHERE s.Field1<>t.Field1"
rs.Open strSQL, cn, 1, 3 ''adOpenKeyset, adLockOptimistic
''Just to see
''If Not rs.EOF Then MsgBox rs.GetString
''Editing one by one (slow)
rs.MoveFirst
Do While Not rs.EOF
rs.Fields("t.Field1") = rs.Fields("s.Field1")
rs.Update
rs.MoveNext
Loop
''Batch update (faster)
strSQL = "UPDATE [;Database=Z:\Documents\Database\Database1.mdb;].Table1 t " _
& "INNER JOIN [Sheet1$] s " _
& "ON s.id=t.id " _
& "SET t.Field1=s.Field1 " _
& "WHERE s.Field1<>t.Field1 "
cn.Execute strSQL
End Sub
Reading data from Access to Excel GetMDB() macro works fine, But when I tried to update the data from Excel to Access, code gives me following error:
Run-time error '3021':
Either BOF or EOF is True, or the current record has been deleted.
Requested operation requires a current record.
I checked the mdb, xlsx and sheet path and names are correct. Anyone got a similar problem as well and how to overcome? Thanks.
You cannot run UPDATE queries using Excel workbook sources as any SQL queries using workbooks are read-only from last saved instance and cannot be updated. Excel simply is not a database to do such transactions with no record-level locking mechanism, read/write access, or relational model. Though you can run append (INSERT INTO ... SELECT *) and make-table queries (SELECT * INTO FROM ...), you cannot run UPDATE that aligns to live values.
However, you can read in an Access recordset and iterate through the Excel cells aligning by ID matches. Below assumes the Excel Sheet's ID column is in Column A and Field1 is in Column B.
Dim accConn As Object, accRST As Object
Dim accFile As String, accStr As String
Dim lastrow As Long, i As Long
Const adOpenKeyset = 1, adLockOptimistic = 3, adCmdTableDirect = 512
lastrow = Workbooks(1).Sheets(1).Cells(Workbooks(1).Sheets(1).Rows.Count, "A").End(xlUp).Row
accFile = "Z:\Documents\Database\Database1.mdb"
accStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & accFile & ";"
Set accConn = CreateObject("ADODB.Connection")
Set accRST = CreateObject("ADODB.Recordset")
accConn.Open accStr
accRST.Open "SELECT * FROM Table1", accConn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
If Not (accRST.BOF And accRST.EOF) Then
accRST.MoveFirst
Else
Msgbox "No records in Access table.", vbInformation
accRST.Close: accConn.Close: Set accRST = Nothing: Set accConn = Nothing
Exit Sub
End If
Do While Not accRST.EOF
For i = 1 to lastrow
If accRST!ID = Workbooks(1).Sheets(1).Range("A" & i) _
And accRST!Field1 <> Workbooks(1).Sheets(1).Range("B" & i) Then
accRST!Field1.Value = Workbooks(1).Sheets(1).Range("B" & i)
End If
Next i
accRST.Update
accRST.MoveNext
Loop
accRST.Close: accConn.Close
Set accRST = Nothing: Set accConn = Nothing
Notes:
If IDs between Excel worksheet and Access table are not one-to-one (i.e., Excel has multiple rows of same ID), the last Field1 value following the If logic will be inserted to corresponding Access row.
Above may be extensive processing if database rows and Excel cells are large. The best option is simply to use Access for all data entry/management and avoid the update needs. Since Excel is a flatfile, consider using it as the end use application and Access as central data repository.
I would like to conditionally copy data from multiple worksheets into a single worksheet in a given workbook in order to consolidate data. The macro would look at column F in all the worksheets, and if a row in column F matches a given number, that row gets copeid. Any help would be great!!
Terry
How about:
Dim cn As Object
Dim rs As Object
Dim ws As Worksheet
Dim wb As Workbook
Dim sSQL As String
Dim sFile As String
Dim sCon As String
Dim sXLFileToProcess As String
sXLFileToProcess = "Book1.xls"
strFile = Workbooks(sXLFileToProcess).FullName
'' Note that if HDR=No, F1,F2 etc are used for column names,
'' if HDR=Yes, the names in the first row of the range
'' can be used.
'' This is the Jet 4 connection string, you can get more
'' here : http://www.connectionstrings.com/excel
sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
'' Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open sCon
'' In this example, the column header for column F is F, see notes
'' above on field (column) names. It also assumes that the sheets to
'' be merged have the same column headers in the same order
'' It would be safer to list the column heards rather than use *.
For Each ws In Workbooks(sXLFileToProcess).Worksheets
sSQL = sSQL & "SELECT * FROM [" & ws.Name & "$] " _
& "WHERE f=3 " _
& "UNION ALL "
Next
sSQL = Left(sSQL, Len(sSQL) - 10)
rs.Open sSQL, cn, 3, 3
'' New workbook for results
Set wb = Workbooks.Add
With wb.Worksheets("Sheet1")
'' Column headers
For i = 1 To rs.Fields.Count
.Cells(1, i) = rs.Fields(i - 1).Name
Next
'' Selected rows
.Cells(2, 1).CopyFromRecordset rs
End With
'' Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing