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
Related
I'm trying to get data from an excel workbook which is updated every month and the name of the file changes according to the date - I have an instructions page using the today function which gives me the month (this are the cell I'm referencing in "Month")
Problem is, the file I'm opening is very very big, and so this takes over 5 minutes just to start excel and copy the data. Is there anyway to modify my code to get the data without opening the excel file?
This is my code so far -
Sub UploadData()
Dim Model As Workbook
Dim Q As Workbook
Dim rngFX As Range
Dim Month As String
Set Model = ActiveWorkbook
Set Q = Workbooks.Open(Filename:=Sheets("Instructions").Range("$C$29").Value)
Month = ("C" & (Model.Sheets("Instructions").Range("$C$23")))
With Q
With .Sheets(Month & " Summary")
Set rngFX = .Range("A61:R66")
rngFX.Copy Destination:=Model.Sheets("FOREX Forecast").Range("A3")
End With
End With
Q.Close savechanges:=False
With Model.Sheets("FOREX Forecast").UsedRange
.Value = .Value
End With
End Sub
Edit: I've added a picture of the error I'm getting - When I press debug it highlights this line:
Rs.Open strSQL, strConn
Try
Sub UploadData()
Dim Model As Workbook
Dim Q As Workbook
Dim rngFX As Range
Dim Year As String
Dim Fn As String, wsName As String
Dim strConn As String
Dim strSQL As String
Dim Ws As Worksheet
Dim Rs As Object
Set Model = ActiveWorkbook
Set Ws = Model.Sheets("FOREX Forecast")
Fn = Sheets("Instructions").Range("$C$29").Value
'Set Q = Workbooks.Open(Filename:=Sheets("Instructions").Range("$C$29").Value)
Month = "C" & Model.Sheets("Instructions").Range("$C$23")
wsName = "[" & Month & " Summary" & "$" & "A61:R66 ]"
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Fn & _
";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
Set Rs = CreateObject("ADODB.Recordset")
strSQL = "select * from " & wsName
Rs.Open strSQL, strConn
Ws.Range("a3").CopyFromRecordset Rs
Rs.Close
Set Rs = Nothing
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 have many excel files in many folders and I need to delete the rows from all files where in column for ex. B are words from array:
For ex. my bad words list:
the sun, tree, big car, cup, ....
If A2 column is 'The Sun is the star at the center of the Solar System.' - this row has been deleted.
If in column is 'thesunis the..' - this row has been deleted. But is bad!
And my questions:
How to delete rows with exact words of array element?
How to count array elements?
How to escape single quote in array element (example in code below)
How to open all files from folder "C://folder" and after run code save all?
Here is my code:
Sub code()
Dim MyValue As String
Dim a As Integer
'------------------------------------------------------
ArrayValueToRemove = Array("the sun", "code 'in", "another")
Range("B:B").Select
'------------------------------------------------------
For Each cell In Selection
MyValue = CStr(cell.Value)
For a = 0 To 2
If InStr(1, LCase(MyValue), LCase(ArrayValueToRemove(a))) > 0 Then
cell.EntireRow.Delete
Exit For
End If
Next
Next cell
End Sub
Sub deleteBadWordRows()
Dim currentFile, currentSheet, badWords As Variant, lastRow, i As Integer, baseDirectory As String
'------------------------------------------------------
baseDirectory = "c:\folder\"
badWords = Array("the sun", "code 'in", "another")
'------------------------------------------------------
currentFile = Dir(baseDirectory)
While (currentFile <> "")
Workbooks.Open baseDirectory + currentFile
For Each currentSheet In Workbooks(currentFile).Worksheets
lastRow = currentSheet.Cells(currentSheet.Rows.Count, "B").End(xlUp).Row
For j = 1 To lastRow
For i = 0 To UBound(badWords)
If InStr(1, LCase(CStr(currentSheet.Cells(j, "B").Value)), LCase(badWords(i))) > 0 Then
currentSheet.Rows(j).Delete
j = j - 1
lastRow = lastRow - 1
Exit For
End If
Next
Next
Next
Workbooks(currentFile).Save
Workbooks(currentFile).Close
currentFile = Dir
Wend
End Sub
Consider an SQL solution to query your string searches using the LIKE operator with wildcard, %. Excel for PC can connect to the Jet/ACE SQL Engine (Window .dll files) and query workbooks. Here you avoid the nested looping except for iterating through workbooks.
Below assumes all worksheets are tabular in structure with column headers all beginning at A1. Query results are dumped to a new worksheet where you can delete current worksheet afterwards. Be sure to replace placeholders with actual names, CurrentWorksheet, ColumnA, NewWorksheet:
Sub DeleteSQL()
Dim conn As Object, rst As Object
Dim strConnection As String, strSQL As String
Dim i As Integer
Dim wb As Workbook
Dim dirpath As String: dirpath = "C:\\Folder"
Dim xlfile As Variant: xlfile = Dir(dirpath & "\*.xls*")
Do While (xlfile <> "")
Set wb = Workbooks.Open(dirpath & "\" & xlfile)
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' WORKBOOK CONNECTION
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='" & dirpath & "\" & xlfile & "';" _
& "Extended Properties=""Excel 8.0;HDR=YES;"";"
' OPEN DB CONNECTION
conn.Open strConnection
' OPEN RECORDSET
strSQL = " SELECT * FROM [CurrentWorksheet$]" _
& " WHERE [ColumnA] LIKE ""%the sun%"" OR [ColumnA]" _
& " LIKE ""%code 'in%"" OR [ColumnA] LIKE ""%another%"""
rst.Open strSQL, conn
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count).Name = "NewWorkSheet"
' RESULTSET COLUMNS
For i = 1 To rst.Fields.Count
wb.Worksheets("NewWorkSheet").Cells(1, i) = rst.Fields(i - 1).Name
Next i
' RESULTSET DATA ROWS
wb.Worksheets("NewWorkSheet").Range("A2").CopyFromRecordset rst
wb.Close True
rst.Close: conn.Close
Set rst = Nothing: Set conn = Nothing
xlfile = Dir
Loop
End Sub
I am very inexperienced with VBA but I am trying to create a macro in and Excel Work Book that will compare static data in another workbook to its corresponding table in SQL DBx
I can successfully pull the information from my Source Work Book. However some of the data is not being copied accross from the Source Workbook if the data type changes from numberic to string.I would also like to copy headers. I have copied this sub below
I was also hoping to create an Output of the entries that are different in each of the tables? Is this possible
Sub Comparison()
Sub Comp()
'
' Macro1 Macro
' Macro recorded Aking
Dim aCtiveBook As String
x = 1
Do While x <= 9
aCtiveBook = ThisWorkbook.Sheets("INPUT").Range("A1").Offset(x, 0)
Dim cn As ADODB.Connection
Dim rt As ADODB.Recordset
Dim cm As ADODB.Command
Set rt = New ADODB.Recordset
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source = " & aCtiveBook & ";" & _
"Extended Properties=Excel 8.0;"
.Open
Sheetq = ThisWorkbook.Sheets("INPUT").Range("B1").Offset(x, 0)
Sheetn = ThisWorkbook.Sheets("INPUT").Range("C1").Offset(x, 0)
rt.Open "Select * from" & "[" & Sheetq & "$" & "]", cn
ThisWorkbook.Sheets(Sheetn).Select
ThisWorkbook.Sheets(Sheetn).Range("A1:BA20000").Delete
Sheets(Sheetn).Range("A2").CopyFromRecordset rt
rt.Close
rt.Open "Select * from [" & Sheetq & "$" & "A1:Z1" & "]", cn
Sheets(Sheetn).Range("A1").CopyFromRecordset rt
rt.Close
End With
x = x + 1
Loop
End Sub
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