I'm trying to populate a listbox in excel with information that is a "matrix"(basically I have some data in the rows and some in the columns. I'm using the code below but I have 2 problems.
Dim Rows As Integer
Dim Kolumns As Integer
Dim Start As Range
Set Start = Sheets("sheet1").Range("B2")
Start.Select
Rows = 10
Kolumns = 5
For i = 1 To Rows
For j = 1 To Kolumns
ListBox1.AddItem
ListBox1.List(i - 1, j - 1) = ActiveCell.Offset(i - 1, j - 1).Value
Next j
Next i
The first problem is that the rows is being doubled, if I write "rows = 10" I then get 20 rows. (The columns work fine).
The second problem is my "select". I know that it's not the best option to use but I don't know how to avoid it?
As already written in the comment, you can use the range variable (in your case Start) directly to access the content of the cells.
The reason that you get 20 instead of 10 entries in the listbox is that you have the AddItem within the inner loop, and that is executed 10*2 = 20 times. You need to move it into the outer loop so that only one item per row is created:
Const rowCount = 10
Const colCount = 2
Dim Start As Range
Set Start = ThisWorkbook.Sheets("sheet1").Range("B2")
Dim i As Long, j As Long
For i = 1 To rowCount
ListBox1.AddItem
For j = 1 To colCount
ListBox1.List(i - 1, j - 1) = Start.Offset(i - 1, j - 1).Value
Next j
Next i
Try the next way, please. No need of any iteration. A ListBox has a List property which accept an array:
Sub loadListBox()
Dim sh As Worksheet, iRows As Long, Kolumns As Long, Start As Range, arr
Set sh = Sheets("Sheet1")
Set Start = sh.Range("B2")
iRows = 10: Kolumns = 5
arr = sh.Range(Start, Start.Offset(iRows, Kolumns)).Value
With ListBox1
.Clear
.ColumnCount = Kolumns + 1
.list = arr
End With
End Sub
Populate List Box
More efficient is not using a loop at all.
Note the use of the ColumnCount property which is used to ensure the right number of columns.
The Code
Option Explicit
Sub populateListBox()
Const rCount As Long = 10
Const cCount As Long = 5
Dim cel As Range: Set cel = Sheet1.Range("B2")
With Sheet1.ListBox1
.ColumnCount = cCount
.List = cel.Resize(rCount, cCount).Value
End With
End Sub
Related
I am trying to do a loop but I'm a little stuck.
Sub Macro()
Range("A392: A401").Value = Range("N2")
Range("A402: A411").Value = Range("N3")
Range("A412: A421").Value = Range("N4")
Range("A422: A431").Value = Range("N5")
....
I need to repeat this logic ( On column A to set a value for each 10 rows) this value will be from Column N from 1 to 1 until it finds an empty row ...
I'm not being able to do the loop with these multiples conditions, would you please help me ?
Thanks a lot!
Range.Offset is a great method to manipulate ranges. Using it, we can automate the ranges to move down the sheet with each loop.
Sub Macro()
Dim i As Long
While Range("N2").Offset(i) <> ""
'Offset will shift N2 down by one each loop
'Offset will shift the 10 cell range down by 10 on each loop
Range("A392: A401").Offset(i * 10).Value = Range("N2").Offset(i)
i = i + 1
Wend
End Sub
I'm not quite sure what's your actual intention:
Repeat all values in column N2:N5 10 times and append the whole data block to the first free cell in column A.
Repeat all non-empty values in column N 10 times and write them to a fixed target starting with cell A392.
In both cases you can prefill an array and write it to the defined target in column A. Looping through an array has some speed advantages whereas looping through a range by means of VBA can be time consuming.
The direct (untested) copying of whole blocks as shown by #Toddleson can improve this behaviour, depending on total range sizes.
Case 1
Sub Example1()
Const RowsCount As Long = 10
With Sheet1 ' << change to your project's sheet (Code)Name
'get values to repeat & count them
Dim vals: vals = .Range("N2:N5")
Dim cnt As Long: cnt = UBound(vals)
'provide for 1-based 2-dim results array
Dim results
ReDim results(1 To RowsCount * cnt, 1 To 1)
'fill array with repeated values
Dim i As Long, j As Long
For i = 1 To cnt
For j = 1 To RowsCount
results((i - 1) * RowsCount + j, 1) = vals(i, 1)
Next j
Next i
'append above data block
Dim nxtRow As Long
nxtRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nxtRow).Resize(UBound(results), 1) = results
End With
End Sub
Case 2
Sub Example2()
Const RowsCount As Long = 10
With Sheet1 ' << change to your project's sheet (Code)Name
'get values to repeat & count them
Dim lastRow As Long
lastRow = .Range("N" & .Rows.Count).End(xlUp).Row
Dim vals: vals = .Range("N2:N" & lastRow)
Dim ValsCount As Long: ValsCount = UBound(vals)
'provide for 1-based 2-dim results array
Dim results
ReDim results(1 To RowsCount * ValsCount, 1 To 1)
'fill array with repeated values
Dim i As Long, j As Long, ii As Long
For i = 1 To ValsCount
If Len(vals(i, 1)) > 0 Then ' check if non-empty value in column N
ii = ii + 1
For j = 1 To RowsCount
results((ii - 1) * RowsCount + j, 1) = vals(i, 1)
Next j
End If
Next i
'write data block to fixed target starting with A392
.Range("A392").Resize(UBound(results), 1) = results
End With
End Sub
Is it possible to get the row positions in a large table in excel without performing a loop?
What I am trying to do is to click on a particular ID, and then the last 3 records from the same ID will be shown in UI.
I am beginner in programming and have no idea how to do this aside from looping method (which is very resource and memory-intensive considering we are looping a large and growing table of 100k rows in every single click from user).
For example: If user is clicking "A123" then we know that their row positions are : 5, 8 , 10
Same as CDP1802 posted but faster finding of last 3 rows.
Sub FilteredAdvanced()
Const nValues As Long = 3 'amount of rows you want to find from the end
Dim ar() As Long
ReDim ar(nValues - 1) As Long
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Dim rng As Range
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
.UsedRange.AutoFilter 'remove filter
End With
Dim n As Long
n = nValues - 1
Dim iArea As Long
For iArea = rng.Areas.Count To 1 Step -1
Dim iRow As Long
For iRow = rng.Areas(iArea).Rows.Count To 1 Step -1
ar(n) = rng.Areas(iArea).Rows(iRow).Row
n = n - 1
If n < 0 Then Exit For
Next iRow
If n < 0 Then Exit For
Next iArea
Dim j As Long
For j = 0 To nValues - 1
Debug.Print ar(j)
Next
End Sub
Looping filtered a list
Option Explicit
Sub Filtered()
Dim rng as Range, ID As Range, a As Range
Dim ar(2) As Long, i As Integer, j As Integer
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
End With
' count
For Each a In rng.Areas
For Each ID In a.Cells
If ID.Row > 1 Then
i = (i + 1) Mod 3
ar(i) = ID.Row
End If
Next
Next
For j = 1 To 3
Debug.Print ar((j + i) Mod 3)
Next
End Sub
I have a bunch of word documents that each contain a single table, some of which hold an exorbitant amount of data (20,000+ rows perhaps) and hence can stretch over hundreds of pages long.
With that being said, I found a VBA word macro that can display all row indices that start every page. For example, the macro will display 100 integers for a table that stretches for 100 pages. This is exactly what I need but for various reasons, the macro runs very slow. Furthermore, it runs even slower when I adapted the code and embedded it into an excel macro (to use on a word object).
So my question is - can this macro be somehow optimized? I suppose the looping is causing the problem. Many thanks for your input!
Sub TableRowData()
'define meaningful names to use for array's first dimension
Const pgnum = 1
Const startrow = 2
Const endrow = 3
Dim data() As Long ' array to hold data
Dim rw As Row ' current row of table
Dim rownum As Long ' the index of rw in table's rows
Dim datarow As Long ' current value of array's second dimension
Dim rg As Range ' a range object for finding the page where rw starts
'initialization
ReDim data(3, 1)
Set rw = ActiveDocument.Tables(1).Rows(1)
rownum = 1
datarow = 1
'store the page number and row number for the first row of the table
Set rg = rw.Range
rg.Collapse wdCollapseStart
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
'Step through the remaining rows of the table.
'Each time the page number changes, store the preceding row as the
'last row on the previous page; then expand the array and store the
'page number and row number for the new row.
While rownum < ActiveDocument.Tables(1).Rows.Count
Set rw = rw.Next
rownum = rownum + 1
Set rg = rw.Range
rg.Collapse wdCollapseStart
If rg.Information(wdActiveEndAdjustedPageNumber) > data(pgnum, datarow) Then
data(endrow, datarow) = rownum - 1
ReDim Preserve data(3, datarow + 1)
datarow = datarow + 1
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
End If
Wend
'finish up with the last row of the table
data(endrow, datarow) = rownum
Dim msg As String
Dim i As Long
For i = 1 To UBound(data, 2)
msg = msg & data(startrow, i) & vbCr
Next i
MsgBox msg
End Sub
Try something based on:
Sub TableRowData()
Dim Doc As Document, Rng As Range, Data() As Long, i As Long, j As Long, p As Long, r As Long, x As Long
Set Doc = ActiveDocument
With Doc
With .Tables(1).Range
i = .Cells(1).Range.Characters.First.Information(wdActiveEndAdjustedPageNumber)
j = .Cells(.Cells.Count).Range.Characters.Last.Information(wdActiveEndAdjustedPageNumber)
ReDim Data(3, j - i)
For p = i To j
Set Rng = Doc.Range.GoTo(What:=wdGoToPage, Name:=p)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
r = Rng.Cells(1).RowIndex
x = p - i: Data(1, x) = x: Data(2, x) = p: Data(3, x) = r
Next
End With
End With
End Sub
Processing tables row by row is notoriously slow and there is little you can do to speed things up.
One thing that will help is to turn off screen updating. At the start of your routine add Application.ScreenUpdating = False and at the end Application.ScreenUpdating = True.
The other thing you can experiment with is using a For Each loop. There is some disagreement as to whether or not this method is faster. Having a large table to process will give you a pretty good idea of which is the faster method, but don't expect miracles. Whichever method you adopt you are going to need patience.
Sub TableRowData()
Application.ScreenUpdating = False
'define meaningful names to use for array's first dimension
Const pgnum = 1
Const startrow = 2
Const endrow = 3
Dim data() As Long ' array to hold data
Dim rw As Row ' current row of table
Dim rownum As Long ' the index of rw in table's rows
Dim datarow As Long ' current value of array's second dimension
'Dim rg As Range ' a range object for finding the page where rw starts
'initialization
ReDim data(3, 1)
Set rw = ActiveDocument.Tables(1).Rows(1)
rownum = 1
datarow = 1
'store the page number and row number for the first row of the table
Set rg = rw.Range
rg.Collapse wdCollapseStart
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
'Step through the remaining rows of the table.
'Each time the page number changes, store the preceding row as the
'last row on the previous page; then expand the array and store the
'page number and row number for the new row.
'While rownum < ActiveDocument.Tables(1).Rows.Count
For Each rw In ActiveDocument.Tables(1).Rows
'Set rw = rw.Next
rownum = rownum + 1
'Set rg = rw.Range
'rg.Collapse wdCollapseStart
If rw.Range.Information(wdActiveEndAdjustedPageNumber) > data(pgnum, datarow) Then
data(endrow, datarow) = rownum - 1
ReDim Preserve data(3, datarow + 1)
datarow = datarow + 1
data(pgnum, datarow) = rw.Range.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
End If
Next rw
'Wend
'finish up with the last row of the table
data(endrow, datarow) = rownum
Dim msg As String
Dim i As Long
For i = 1 To UBound(data, 2)
msg = msg & data(startrow, i) & vbCr
Next i
MsgBox msg
Application.ScreenUpdating = True
End Sub
How about looping through the pages and getting the row number?
Would that work?
Dim doc As Document
Dim rng As Range
Dim pg As Long
Application.ScreenUpdating = False
Set doc = ThisDocument
For pg = 1 To doc.Range.Information(wdNumberOfPagesInDocument)
Set rng = doc.GoTo(wdGoToPage, wdGoToAbsolute, pg)
Debug.Print rng.Information(wdEndOfRangeRowNumber)
Next pg
I am trying to number column A in increments by 1, based on how many rows are in column B Example of my Excel sheet
The code I currently have does this, but the top number does not end up being 1. I need to start with 1 at the top and count down.
Sub SecondsNumbering()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Data Formatted")
Dim LastRow As Long
Dim i As Long
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 6 To LastRow
.Cells(i, 1).Value = i - 1
Next
End With
End Sub
With this, I am counting the number of rows in the column.
Edit: When I do the value 7 for i, so that it starts at 6 (which is where I want data to start) this is what I get.
How about...
Option Explicit
Sub Test()
Dim lCntr As Long
lCntr = 6
Do
If (Cells(lCntr, 2) <> "") Then Cells(lCntr, 1) = lCntr - 5
lCntr = lCntr + 1
Loop Until Cells(lCntr, 2) = ""
End Sub
HTH
I have a large table of lab measurement logs, which I work with using arrays.
(Im a chemist, a lab technician and Ive started to learn VBA only last week, please bear with me.)
Im trying to figure out, how to load the table into an array and then remove rows with an empty value in the 5th column so that I can "export" the table without blanks in the 5th column via an array into a different sheet.
I first tested this with some code I found for a 1D array, where I would make 2 arrays, one placeholder array which Id loop through adding only non-blanks to a second array.
For Counter = LBound(TestArr) To UBound(TestArr)
If TestArr(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
NoBlanksArr(UBound(NoBlanksArr)) = TestArr(Counter, 1)
ReDim Preserve NoBlanksArr(0 To UBound(NoBlanksArr) + 1)
End If
Next Counter
It works in 1D, but I cant seem to get it two work with 2 dimensions.
Heres the array Im using for reading and outputting the data
Sub ArrayTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim TestArray() As Variant
Dim Dimension1 As Long, Dimension2 As Long
Sheets("Tracker").Activate
Dimension1 = Range("A3", Range("A2").End(xlDown)).Cells.Count - 1
Dimension2 = Range("A2", Range("A2").End(xlToRight)).Cells.Count - 1
ReDim TestArray(0 To Dimension1, 0 To Dimension2)
'load into array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
TestArray(Dimension1, Dimension2) = Range("A4").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
Sheets("Output").Activate
ActiveSheet.Range("A2").Select
'read from array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
ActiveCell.Offset(Dimension1, Dimension2).Value = TestArray(Dimension1, Dimension2)
Next Dimension2
Next Dimension1
Erase TestArray
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thank you for any help in advance.
The Redim Preserve statement does not work for two-dimensional arrays if you want to change the number of records (rows).
You could load the range into an array, and then when you want to export the array to another range, loop through that array while skipping blank records.
An example:
Option Explicit
Sub ArrayTest()
Dim wb As Workbook, wsInput As Worksheet, wsOutput As Worksheet
Dim myArr As Variant
Dim i As Long, k As Long, LRow As Long
Set wb = ThisWorkbook
Set wsInput = wb.Sheets("Tracker")
Set wsOutput = wb.Sheets("Output")
LRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row + 1
'Load a range into the array (example range)
myArr = wsInput.Range("A1:Z100")
'Fill another range with the array
For i = LBound(myArr) To UBound(myArr)
'Check if the first field of the current record is empty
If Not Len(myArr(i, 1)) = 0 Then
'Loop through the record and fill the row
For k = LBound(myArr, 2) To UBound(myArr, 2)
wsOutput.Cells(LRow, k) = myArr(i, k)
Next k
LRow = LRow + 1
End If
Next i
End Sub
From your code, it appears you want to
test a column of data on a worksheet to see if there are blanks.
if there are blanks in the particular column, exclude that row
copy the data with the excluded rows to a new area
You can probably do that easier (and quicker) with a filter: code below checking for blanks in column2
Option Explicit
Sub removeCol2BlankRows()
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim rSrc As Range, rRes As Range
Set wsSrc = ThisWorkbook.Worksheets("sheet1")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion 'many ways to do this
Set wsRes = ThisWorkbook.Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 10)
If wsSrc.AutoFilterMode = True Then wsSrc.AutoFilterMode = False
rSrc.AutoFilter field:=2, Criteria1:="<>"
rSrc.SpecialCells(xlCellTypeVisible).Copy rRes
wsRes.AutoFilterMode = False
End Sub
If you really just want to filter the VBA arrays in code, I'd store the non-blank rows in a dictionary, and then write it back to the new array:
Option Explicit
Sub removeCol2BlankRows()
Dim testArr As Variant
Dim noBlanksArr As Variant
Dim myDict As Object
Dim I As Long, J As Long, V
Dim rwData(1 To 4) As Variant
With ThisWorkbook.Worksheets("sheet1")
testArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
Set myDict = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(testArr, 1)
If testArr(I, 2) <> "" Then
For J = 1 To UBound(testArr, 2)
rwData(J) = testArr(I, J)
Next J
myDict.Add Key:=I, Item:=rwData
End If
Next I
ReDim noBlanksArr(1 To myDict.Count, 1 To 4)
I = 0
For Each V In myDict.keys
I = I + 1
For J = 1 To 4
noBlanksArr(I, J) = myDict(V)(J)
Next J
Next V
End Sub