I have a recordset rsDatabase which is the output of a SELECT * FROM query, so I want to take this recordset and only paste rows when the value in a particular column for that row is true.
So it would be something like this:
xlRow = 1
Do While Not rsDatabase.EOF
If rsDatabase(rsDatabaseCol).Value = "example" Then
'Paste the row here
xlRow = xlRow + 1
End If
rsDatabase.MoveNext
Loop
But I can't work out what the syntax is for only pasting one row.
According to your comment I would suggest to use the filter method of a recordset and then use CopyFromRecordSet. No loop is needed unless you want to add the column names at the top of table.
For i = 0 To rsDatabase.Fields.Count - 1
Range("A1").Offset(0, i) = rsDatabase.Fields(i).Name
Next i
rsDatbase.Filter = rsDatabaseCol & " = 'example'"
rsDatabase.Range("A2").CopyFromRecordset
Related
I have some queries related to the VBA script. I have a large number of data in an excel file These all are formula-based values so I can't use special cell functions as well.
Now I need a VBA script that will arrage the table in a proper way. I need if there is any cell blank then the value in the next cell will move left.
Like the below image.
Currently, I'm using the below code but it's taking too much time as its' looping through the entire database one by one. Is there any better way to perform this?
lastrow = Range("B" & Rows.Count).End(xlUp).Row
Repeat = 4
For cellno = 1 To Repeat
For rowno = 2 To lastrow
'Debug.Print cellno
'Debug.Print rowno
If Range(Col1 & rowno).Value = "" Then
Range(Col2 & rowno).Cut
Range(Col1 & rowno).Select
ActiveSheet.Paste
End If
If Range(Col2 & rowno).Value = "" Then
Range(Col3 & rowno).Cut
Range(Col2 & rowno).Select
ActiveSheet.Paste
End If
If Range(Col3 & rowno).Value = "" Then
Range(Col4 & rowno).Cut
Range(Col3 & rowno).Select
ActiveSheet.Paste
End If
If Range(Col4 & rowno).Value = "" Then
Range(Col5 & rowno).Cut
Range(Col4 & rowno).Select
ActiveSheet.Paste
End If
Next rowno
Next cellno
If you just need the values, and not the underlying formulas, Power Query (available in Windows Excel 2010+ and Office 365) may be a better option. Certainly should be faster.
Select some cell in your original table
Data => Get&Transform => From Table/Range
When the PQ UI opens, navigate to Home => Advanced Editor
Make note of the Table Name in Line 2 of the code.
Replace the existing code with the M-Code below
Change the table name in line 2 of the pasted code to your "real" table name
Examine any comments, and also the Applied Steps window, to better understand the algorithm and steps
The basic algorithm consists of:
Transpose the table
Remove the nulls (blanks) from each column
Transpose the table back
PQ has an easier time removing nulls from columns and collapsing them than from rows
M Code
let
//Change Table name in next line to your actual table (or range) name in your workbook
Source = Excel.CurrentWorkbook(){[Name="Table5"]}[Content],
//Demote the headers, then transpose the table
#"Demoted Headers" = Table.DemoteHeaders(Source),
tt = Table.Transpose(#"Demoted Headers"),
/*convert each column into a list,
remove the nulls from the list,
then recreate the table from the list of columns */
remNulls = let
colNames = Table.ColumnNames(tt),
cols = List.Generate(
()=> [col = List.RemoveNulls(Table.Column(tt,colNames{0})), i=1],
each [i] <= Table.RowCount(tt),
each [col = List.RemoveNulls(Table.Column(tt,colNames{[i]})) , i = [i]+1],
each [col])
in
Table.FromColumns(cols),
//transpose the table back to original and promote the headers
#"Transposed Table" = Table.Transpose(remNulls),
#"Promoted Headers" = Table.PromoteHeaders(#"Transposed Table", [PromoteAllScalars=true]),
//set data types to Text (could do something different if needed)
typeIt = Table.TransformColumnTypes(#"Promoted Headers",
List.Transform(Table.ColumnNames(#"Promoted Headers"),each {_, Text.Type}))
in
typeIt
Moving the data to a Variant Array, looping that, then moving the data back to the range will speed this up a lot.
Since you are dealing with Formulas, use Range.Formula2 to get the data (or Range.Formula if you are not using a version of Excel that supports Dynamic Arrays)
Sub Demoz()
Dim rng As Range
Dim lo As ListObject
Dim dat As Variant
Dim rw As Long, cl As Long, idx As Long
' Get a reference to your Data range
Set rng = Workbooks("YourWorkbook").Worksheets("YourWorksheet").Range("YourDataRange")
' Move data to a Variant Array
' Dynamic Array versions of Excel
dat = rng.Formula2 '
' Non-Dynamic Array versions of Excel
'dat = rng.Formula
' Loop the Data Array
For rw = 1 To UBound(dat, 1)
' Find first blank column in current row
idx = 0
For cl = 1 To UBound(dat, 2)
If dat(rw, cl) = vbNullString Then
idx = cl
Exit For
End If
Next
' If row contains some blanks
If idx > 0 Then
' Loop the row
For cl = 1 To UBound(dat, 2)
' If cell contains data
If dat(rw, cl) <> vbNullString Then
' If cell needs to be moved
If idx < cl Then
' Move cell to the left most empty cell
dat(rw, idx) = dat(rw, cl)
dat(rw, cl) = Empty
idx = idx + 1
End If
End If
Next
End If
Next
' Place results back on sheet
' Dynamic Array versions of Excel
rng.Formula2 = dat
' Non-Dynamic Array versions of Excel
'rng.Formula = dat
End Sub
On my hardware a range of 100,000 rows, 10 columns is processed in about 3 seconds. YMMV
This example combined with what you have may speed up the process a bit, rather than using cut and paste it shifts the data around. Also note the use of IsEmpty.
Sorry I couldn't type up a full working example, computer is on the fritz at the moment and using an email or something was making me lose my concentration while trying.
https://learn.microsoft.com/en-us/office/troubleshoot/excel/loop-through-data-using-macro
I am working with a VB macro. Essentially what I am trying to do is for the macros to read the input and first determine whether or not a cells ID number matches the one in the row. Example: If row 1 has an ID of 1122 and rows 2,3,4 and 5 all match, I want the macro to read that and create a count in the NbrOfA cell. Once it realizes that there is not an ID match it moves on to the next ID and looks for matches of that ID number and continues to create a count. While it is doing this, I also need it to read from another column that has specific strings such as "open", "closed" ect. read that input, and create a separate row titled NbrofOpenA. Once it runs out of data, I then want to have a singular cell that shows the number of actions (NbrOfA) that match the ID number as well as the number of open actions (NbrOfOpenA).
Currently I receive the error: “compile error: sub or function not defined” highlighting the Set Cell(Sheet2.Cells(FirstRowOfI, 23) = NbrOfA
Attached in the excel sheet attached it shows 2 cells deleted. They will not actually be deleted, just wanted to give an idea of what I was looking for
Sub ACount()
Dim FirstRowofI
Dim NbrOfA as Integer
Dim NbrOfOpenA as Integer
Row = 2
Set FirstRowofI = (Sheet2.Cells.Range(Row, 14))
NbrOfA = 0
NbrOfOpenA = 0
If (Sheet2.Cells(Row, 14).Value <> "") Then
NbrOfA = 1
If (Sheet2.Cells(Row, 22) <> "Closed") Then
NbrOfOpenA = 1
Set Row = FirstRowofI
Row = Row + 1
Do While (Sheet2.Cells(Row, 14) = (Sheet2.Cells(FirstRowofI, 14)))
NbrOfOpenA = NbrOfOpenA + 1
If (Sheet2.Cells(Row, 22) <> "Closed" Then
NbrOfOpenA = NbrOfOpenA + 1
Range(Row).EntireRow.Delete
Return
End If
Set Cell(Sheet2.Cells(FirstRowofI, 23)) = NbrOfA
Set Cell(Sheet2.Cells(FirstRowofI, 24)) = NbrOfOpenA
Loop
End Sub
[1
Do you need VBA? You can easily achieve what you're looking for with formulas, heck even a Pivot Table! Here's an example with formulas:
I have been assigned the task to calculate some values from Access and store them to Excel. My code works if I use a single-column database.
My code looks like this:
With Recordset
Source = "SELECT tbl_cog.[Latitude] FROM tbl_cog WHERE Company='Bandung Food Truck Festival Members'"
.Open Source:=Source, ActiveConnection:=Connection
For Col = 0 To Recordset.Fields.Count - 1
TextBox1.Value = Recordset.Fields(Col).Value
Next
End With
But when I want to read multiple columns, my code just reads one column. My code looks like this:
With Recordset
Source = "SELECT tbl_cog.[Latitude], tbl_cog.[Longitude] FROM tbl_cog WHERE Company='Bandung Food Truck Festival Members'"
.Open Source:=Source, ActiveConnection:=Connection
For Col = 0 To Recordset.Fields.Count - 1
TextBox1.Value = Recordset.Fields(Col).Value
TextBox2.Value = Recordset.Fields(Col).Value
Next
End With
UPDATE:
My program with 1 column like this: https://prntscr.com/a90g5z
My program with 2 column like this: https://prntscr.com/a90gpi
My database access like this: https://prntscr.com/a90h0q
Assuming that there is only one record in Recordset, then you should correct your code like shown in the following snippet:
TextBox1.Value = Recordset.Fields(0).Value
TextBox2.Value = Recordset.Fields(1).Value
and so on (in case you have more than two fields). Apparently, you do not need For loop to complete this task.
I have used this method to bring data from Access to Excel:
DataArray = Recordset.GetRows() 'all the data from the Select is transferred to an array
nb_rows = UBound(DataArray, 1) 'calculate the number of rows of the array
nb_cols = UBound(DataArray, 2) 'calculate the number of columns of the array
'paste the array to excel
Sheets(1).Range(Cells(1, 1), Cells(nb_rows, nb_cols)).Value = DataArray
'if you want the first 3 columns just replace Cells(nb_rows, nb_cols) with Cells(nb_rows, 3)
Use this code to replace "for col=0 To Recordset.Fields.Count - 1 .... next"
I am having a problem with finding duplicates in an excel column that is created via VBscript.
I currently am grabbing data from a DB opening an excel file, placing the data within and then sorting the data alphabetically ascending on column E (if this isn't needed it can easily be removed).
Now the problem that I am faced with is that I am trying to find any duplicates within that column E (Errors).
If there is a duplicate I would like to copy the duplicate and paste it into another sheet (column A) that I have created
Set oWS7 = oWB.Worksheets(7)
oWB.Sheets(7).Name = "Dups"
And in column B of oWS7 I would like to put all the corresponding column C's (accounts) from the original worksheet.
So that there would be a 1 Error to many account's ratio. If there are no duplicates I would like to have them left alone. I'm not sure how clear this is but any questions/help on this would be much appreciated.
Thanks in advance.
I'm going to make the following assumptions:
The content in the worksheet starts in the first row
The first row (and only the first row) is a header row.
There are no empty rows between header row and data rows.
The data is already sorted.
If these assumptions apply the following should work (once you put in the correct sheet number):
Set data = oWB.Sheets(...) '<-- insert correct sheet number here
j = 1
For i = 3 To data.UsedRange.Rows.Count
If data.Cells(i, 5).Value = data.Cells(i-1, 5).Value Then
oWS7.Cells(j, 1).Value = data.Cells(i, 5).Value
oWS7.Cells(j, 2).Value = data.Cells(i, 3).Value
j = j + 1
End If
Next
'How To find Repeted Cell values from source excel sheet.
Set oXL = CreateObject("Excel.application")
oXL.Visible = True
Set oWB = oXL.Workbooks.Open("ExcelFilePath")
Set oSheet = oWB.Worksheets("Sheet1") 'Source Sheet in workbook
r = oSheet.usedrange.rows.Count
c = oSheet.usedrange.columns.Count
inttotal = 0
For i = 1 To r
For j = 1 To c
If oSheet.Cells(i,j).Value = "aaaa" Then
inttotal = inttotal+1
End If
Next
Next
MsgBox inttotal
oWB.Close
oXL.Quit
I am currently using VBA to run a stored procedure and stored data that been extracted to table. Then, the VBA will query all the data in the data accordingly and put it into excel.
Here the problem, it takes so long for the VBA to extract all data (around 100k rows of data) into excel. Is there any other way to speed up the process? Below is part of my code. The one in bold is the insertion to excel code.
'Row number where data inserting starts
Do
current_sheet = owb.ActiveSheet
With current_sheet
'Insert header to worksheet in first row, ie. A1, B1, C1
For i = 0 To data_cols.GetLength(0) - 1
cell = data_cols(i, 0) & header_row_num 'Change to header_row_num
.Range(cell).Value = data_cols(i, 1)
Next i
End With
row_count = header_row_num + 1 'Change the first row count to a row after header_row_num
'Insert data to worksheet
While rs.EOF = False
With current_sheet
'Set format of specic columns before inserting data
.Columns("A").NumberFormat = "#"
.Columns("B").NumberFormat = "#"
.Columns("C").NumberFormat = "#"
.Columns("D").NumberFormat = "#"
.Columns("E").NumberFormat = "#"
.Columns("F").NumberFormat = "#"
.Columns("G").NumberFormat = "#"
.Columns("H").NumberFormat = "#"
.Columns("I").NumberFormat = "#"
.Columns("J").NumberFormat = "#"
.Columns("K").NumberFormat = "#"
.Columns("L").NumberFormat = "#"
.Columns("M").NumberFormat = "#"
.Columns("N").NumberFormat = "#"
.Columns("O").NumberFormat = "#"
.Columns("P").NumberFormat = "#"
.Columns("Q").NumberFormat = "#"
.Columns("R").NumberFormat = "#"
.Columns("S").NumberFormat = "#"
**'Start inserting data
For i = 0 To data_cols.GetLength(0) - 1
'Get the cell name
cell = data_cols(i, 0) & row_count
'Populate data to the cell
If IsDBNull(rs.Fields(data_cols(i, 2)).Value()) Then
.Range(cell).Value = " "
Else
.Range(cell).Value = rs.Fields(data_cols(i, 2)).Value()
End If
Next i
End With
rs.MoveNext()
'Indicates next row
row_count += 1**
If row_count > 60000 Then
owb.Worksheets.Add(, current_sheet)
need_new_sheet = True
Console.WriteLine("Added new sheet to workbook...")
Exit While
Else
need_new_sheet = False
End If
End While
Loop While (need_new_sheet And rs.EOF = False)
In case certain variable you need to know.
row_count = header_row_num + 1 'Change the first row count to a row after header_row_num
oxl = CreateObject("Excel.Application")
oxl.Visible = False
owb = oxl.Workbooks.Add
Dim data_cols(,) As String = {{"A", "Name", "NAME"}, _
{"B", "Age", "AGE"}} (Not real columns, example)
Any advice or thoughts would be greatly appreciate. Thanks in advance :)
Filling up 100k rows in Excel will definitely take time.
This is what you can do to minimize the time
Use oxl.ScreenUpdating = False in the beginning of the macro and set it to True in the end.
You might want to store the data in the array and then writing the array to Excel in one go in the end. This would definitely decrease the execution time
Excel 2007 onwards Excel has a row limitation of 1048576 rows so you might want to take that into consideration if you cross that limit.
Console.WriteLine("Added new sheet to workbook...") is VB.net. Use Debug.print if you are using VBA.
BTW this will not have significant effect on the speed but you can write the following code
Which is
.Columns("A").NumberFormat = "#"
.Columns("B").NumberFormat = "#"
'
'
'
.Columns("R").NumberFormat = "#"
.Columns("S").NumberFormat = "#"
as
.Columns("A:S").NumberFormat = "#"
The fastest method is CopyFromRecordset.
From MSDN :
expression.CopyFromRecordset(Data, MaxRows, MaxColumns)
expression: Required. An expression that returns a Range object.
Data: Required Variant. The name of the Recordset object to copy into
the range.
MaxRows: Optional Variant. The maximum number of records to copy onto
the worksheet. If this argument is omitted, all the records in the
Recordset object are copied.
MaxColumns: Optional Variant. The maximum number of fields to copy
onto the worksheet. If this argument is omitted, all the fields in the
Recordset object are copied.
For example, in your case just type:
Range("A2").CopyFromRecordset rs