Im having a trouble understanding For and Do while.
Im trying to put items in a listbox in this order:
1 2 3 4 5 6 7 8 9 10
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8
and so on.
And the same way around
1
1 2
1 2 3
Up intil 10
How should i attack this issue?
This is what im stuck with:
Dim counter1 As Integer
Dim counter2 As Integer
For counter1 = 10 To 1 Step -1
For counter2 = 1 To 10
ListBox1.Items.Add()
Next counter2
Next counter1
Your problem is not with using the Loops alone but with using the ListBox Methods. You can achieve what you want in 2 ways:
Initially concatenate (connect) the numbers into a single string and then add it on the Listbox using AddItem Method.
Populate a multicolumn ListBox using a nested loop using AddItem and List method.
The first one should be something like below:
Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, k As Integer
Dim s As String
k = 11 ' this determines the exit condition
For i = 1 To 10
For j = 1 To 10
If k = j Then Exit For
s = IIf(s = "", j, s & " " & j) ' construct the string
Next
Me.ListBox1.AddItem s ' add in listbox
s = ""
k = k - 1
Next
End Sub
Which will result to:
Edit1 No.2 Above
Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, k As Integer
With Me.ListBox1
.ColumnCount = 10
.ColumnWidths = "15;15;15;15;15;15;15;15;15;15"
k = 10 ' determines exit condition
For i = 1 To 10
For j = 1 To 10
If j = 1 Then
.AddItem j ' if it is the number 1, use AddItem method
Else
.List(.ListCount - 1, j - 1) = j ' else use the List method
End If
If k = j Then Exit For
Next
k = k - 1
Next
End With
End Sub
This time, we do not add concatenated numbers into the ListBox but we add it 1 by 1 in each row and column of a multicolumn ListBox. Result would be:
I leave the ascending numbers to you. :) I hope this gets you going.
Related
Never used VBA before and basically just trying write this sub:
Sub Populate_Empties()
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim k As Integer
' test for 50 rows...then change i from 2 to 278970
m = 2
For k = 3 To 8
For i = 2 To 50
If (IsEmpty(Cells(i, k).Value)) Then
m = i 'any statement
Else
j = i - 1
For n = m To j
Cells(n, k).Value = Cells(i, k).Value
m = i + 1
End If
End Sub
I keep getting error End If without Block
Any suggestions?
You're missing the closing statements on your for loops
Sub Populate_Empties()
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim k As Integer
' test for 50 rows...then change i from 2 to 278970
m = 2
For k = 3 To 8
For i = 2 To 50
If (IsEmpty(Cells(i, k).Value)) Then
m = i 'any statement
Else
j = i - 1
For n = m To j
Cells(n, k).Value = Cells(i, k).Value
Next n
m = i + 1
End If
Next i
Next k
End Sub
I want to copy some columns of an excel sheet to another sheet.
I have written the code, which doesnt work. It gets into an infinite loop, and exits with an error. The code is:
Sub customCopy()
Dim i As Integer
Dim j As Integer
j = 1
For i = 1 To 700
If i Mod 5 = 2 Then
Columns(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
If i Mod 5 = 3 Then
Columns(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
If i Mod 5 = 4 Then
Columns(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
Next i
End Sub
Please help..
Copying a column into a row won't work.............a row is too small!
I think what I'm trying to do is pretty basic, but I'm brand new to VBA so I'm getting stuck and the answers I've found are close, but not quite right.
I have a list of row entries, like this:
1 4 32 2 4
2 6 33 1 3
1 4 32 2 4
4 2 30 1 5
Notice that rows 1 and 3 are duplicates. I'd like to only have a single instance of each unique row but I don't want to just delete the duplicates, I want to report how many of each type there are. Each row represents an inventory item, so deleting duplicate entries without indicating total quantity would be very bad!
So, my desired output would look something like this, where the additional 6th column counts the total number of instances of each item:
1 4 32 2 4 2
2 6 33 1 3 1
4 2 30 1 5 1
My data sets are larger than just these 5 columns, they're closer to 10 or so, so I'd like to put that last column at the end, rather than to hardcode it to the 6th column (i.e., column "F")
Update:
I found some code that worked with minor tweaking, and it worked this morning, but after messing around with some other macros, when I came back to this one it was telling me that I have a "compile error, wrong number of arguments or invalid property assignment" and it seemed to be unhappy with the "range". Why would working code stop working?
Sub mcrCombineAndScrubDups2()
For Each a In range("A1", Cells(Rows.Count, "A").End(xlUp))
For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row - a.Row
If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then
a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4)
a.Offset(r, 0).EntireRow.Delete
r = r - 1
End If
Next r
Next a
End Sub
Assuming that your data starts from A1 on a worksheet named ws1, the following code removes the duplicated rows. Not by shifting the whole table but deleting the entire row.
Sub deletedupe()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim row1 As String
Dim row2 As String
i = 1
j = 1
k = 1
Do While Sheets("ws1").Cells(i, 1).Value <> ""
row1 = ""
j = 1
Do While Sheets("ws1").Cells(i, j).Value <> ""
row1 = row1 & Sheets("ws1").Cells(i, j).Value & " "
j = j + 1
Loop
k = i + 1
Do While Sheets("ws1").Cells(k, 1).Value <> ""
row2 = ""
j = 1
Do While Sheets("ws1").Cells(k, j).Value <> ""
row2 = row2 & Sheets("ws1").Cells(k, j).Value & " "
j = j + 1
Loop
If row1 = row2 Then
Sheets("ws1").Rows(k).EntireRow.Delete
Else
k = k + 1
End If
Loop
i = i + 1
Loop
End Sub
I have a workbook that has thousands of defined name regions located in various worksheets. I'm trying to extract them all and line them up in another workbook.
Most of the defined name regions are 1 row tall (and hundreds of cols wide)... but a few are 3-4 rows tall.
So for example,
Name1
10 5 10 12 30 10 12 10 5 10 12 30 10 12 ...
Name2
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
For instances where the region is more than one row tall, I'd like to collapse it to a single row by taking the SUM of the entire column.
So Name2 would be copied to the new workbook as the following:
30 33 30 36 90 30 36 30 33 30 36 90 30 36
I have some VBA/VBS written that works perfectly (and fast!) for cases where the region is 1 row tall, but I'm not sure how to handle summing the taller regions in an efficient way.
What's the best way to fill in the question marks below?
My code so far hasn't had to explicitly loop through the cells of a region; I'm hoping that that won't be the case here either. Any advice appreciated!
Dim irow
irow = 0
Dim colsum
'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names
'rem Dont copy any name that isnt visible
If nm.Visible = True Then
'rem Only copy valid references that start with "ByWeek"
If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then
'rem Only copy if the range is one row tall
If nm.RefersToRange.Row.Count = 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
wsDest.Range("A3",wsDest.Cells(3,nm.RefersToRange.Columns.Count+1)).Offset(irow, 1).Value = nm.RefersToRange.Value
irow = irow + 1
' rem If the named region is several rows tall, then squish it into one row by taking SUM of each column
elseif nm.RefersToRange.Row.Count > 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
???????????????????????????????????
irow = irow + 1
End If
End If
End if
Next
You can update your code such that it adds all the cells in the given range (nm.RefersToRange), independently upon the number of cells:
Dim irow
irow = 0
'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names
'rem Dont copy any name that isnt visible
If nm.Visible = True Then
'rem Only copy valid references that start with "ByWeek"
If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then
If nm.RefersToRange.Rows.Count >= 1 Then
wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
Dim totVal As Long: totVal = 0 'I assumed that target values are Long; update this to the proper type is required
For Each cell In nm.RefersToRange.Cells
If (IsNumeric(cell.Value)) Then totVal = totVal + cell.Value
Next
wsDest.Range("A3", wsDest.Cells(3, nm.RefersToRange.Columns.Count + 1)).Offset(irow, 1).Value = totVal
irow = irow + 1
End If
End If
End if
Next
there is no best way as everyone might think their way is the best.
I would suggest using arrays instead of working with the range objects directly as arrays would have been much faster.
Consider
Now running the code
Option Explicit
Sub Main()
Dim lastRow As Long
Dim lastCol As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Dim arr As Variant
arr = Range(Cells(1, 1), Cells(lastRow, lastCol))
ReDim sumArr(UBound(arr, 2)) As Variant
Dim i As Long
Dim j As Long
Dim colSum As Long
For i = LBound(arr, 1) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
colSum = colSum + arr(j, i)
Next j
sumArr(i) = colSum
colSum = 0
Next i
ReDim finalArray(UBound(sumArr) - 1) As Variant
For i = 1 To UBound(sumArr)
finalArray(i - 1) = sumArr(i)
Next i
Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray
End Sub
Results in
The idea to use arrays is taken from here
And all you need to do is modify the range you want to reprint the array to
Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray
So if you use the above code I think all you'll need to change will be
wsDest.Range("A3").Resize(1, UBound(finalArray, 1) + 1) = finalArray
Here's the code I ended using: It loops through each column for the defined named range. It isn't fast, but it works well enough, as 90% of my ranges are just one row tall.
I've just inserted this code where where it says ????...???? in my question above, :
For j = 1 To nm.RefersToRange.Columns.Count
colsum = 0
For i = 1 To nm.RefersToRange.Rows.Count
If IsNumeric(nm.RefersToRange.Cells(i, j).Value) Then
colsum = colsum + nm.RefersToRange.Cells(i, j).Value
End If
Next
wsDest.Range("A3").Offset(irow, j).Value = colsum
Next
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub