I'm trying to create a code that randomly selects a specific number of rows in a list. The problem that i want to prevent selecting empty rows and some specific value, for example "54555". Maybe someone could help me? Here's my code below
Sub Button1_Click()
Dim d As Object, r As Range, vKeys, x&
'get a set of 3 unique numbers
Set d = CreateObject("Scripting.Dictionary")
While d.Count < 3
'Define the min,max of your numbers
x = RndBetween(6, 11)
If Not d.Exists(x) Then d.Add x, Empty
Wend
'Create a multiarea range
vKeys = d.keys
Set r = Rows(vKeys(0))
For x = 1 To UBound(vKeys)
Set r = Union(r, Rows(vKeys(x)))
Next
'Select it
r.Select
Selection.Copy
Range("A1").Select
Worksheets("Ausinës").Paste
r.Delete
End Sub
Function RndBetween(low&, high&) As Long
RndBetween = CLng(Rnd * (high - low)) + low
End Function
Related
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
HERE IS A NEW IMAGE HOPEFULLY SHOWING WHAT HAS TO MOVE AND WHERE'Here is a sample of some code I have been trying.
sub
For Each cel In Range("W2:W1000")
If cel.Value = "Credit Adj W/O To Collection" AND
Range("AI2:AI1000").Cells.Value > "" THEN
cel.Offset(0,-9).value =
end sub
Basically I need to look in column W for a specific text and if it is found move the number in the next column, col X over to column Y in the same row as the data in column AI, but in column Y. My issue is the amount of rows it has to move up is different based on where the data is in column AI. See screenshot
All of you have been a great help but it is still not moving any numbers. I added another screenshot. I need to look for the text in blue, if found move the amount in column X two columns right and up to the row that has a value in column AI. That gap could be different for each entry, as shown in the screen shot. could be 2 or 4 or 5, just depends on Column AI. Also first entry may not always start in the same row as it does here. The spot in column W and AI may be different throughout the spreadsheet. Hope this helps define my purpose a little.
Everyone has had great ideas but still not working, logic in answers makes sense but it is not grabbing any of the data much less move it. Not sure what is up.
Try this:
Sub tester()
Dim c As Range, ws As Worksheet, rw As Range
Set ws = ActiveSheet 'always use an explicit sheet reference
For Each c In ws.Range("W2:W1000").Cells
Set rw = c.EntireRow 'the whole row for the cell
If c.Value = "Credit Adj W/O To Collection" And _
IsNumeric(rw.Columns("X").Value) Then
'copy the value to Col Y in the row above which has a value in Col AI
ws.Cells(rw.Columns("AI").End(xlUp).Row, "Y").Value = rw.Columns("X").Value
rw.Columns("X").ClearContents ' clear the "X" value
End If
Next c
End Sub
A Tricky Column Update
Loop (r = r + 1) from the first row to the last row (the latter calculated in column W).
When column AI is not blank, write the row number to a variable (rFound).
Continue looping (r = r + 1). When column W is equal to the string Credit Adj W/O To Collection, write the value in column X of the current row to column Y of the row kept in the variable (rFound).
Continue looping (r = r + 1) by alternating between steps 2. and 3. until the last row.
Option Explicit
Sub UpdateInsAmt()
Const wsName As String = "Sheet1"
Const rStart As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rLast As Long: rLast = ws.Cells(ws.Rows.Count, "W").End(xlUp).Row
Dim r As Long: r = rStart
Dim rFound As Long
Do
If Len(CStr(ws.Cells(r, "AI").Value)) > 0 Then ' is not blank
rFound = r
r = r + 1 ' it can't be in the same row
Do
If StrComp(CStr(ws.Cells(r, "W").Value), _
"Credit Adj W/O To Collection", vbTextCompare) = 0 Then
ws.Cells(rFound, "Y").Value = ws.Cells(r, "X").Value
Exit Do ' value found and written so stop looping ...***
'Else ' value not found ...
End If
r = r + 1 ' ... so incremenet row
Loop Until r > rLast
' Else ' is blank ...
End If
r = r + 1 ' ... so increment row, ...*** and increment row
Loop Until r > rLast
End Sub
I wrote a program using VBA which shown below. there was an array(ary) which contain(C,F,B,PC,PB). I create the loop to go through each variable in the array.
what I want to do with my code is I have a datasheet that includes that array values as categories. I want to assign each array values to p range. then execute data from the p range. then want to assign p to next array value and do the same.
but the problem is range p is firstly set ary(1)="C" and give the correct result. but after it becomes equal to "F" didn't work properly. it contains the same range previously gave. can anyone help me with this problem?
For i = 1 To UBound(ary)
cat = ary(i)
Set p = Nothing
Set c = Nothing
For Each c In Range("E:E")
If c.Value = cat Then
If p Is Nothing Then
Set p = c.Offset
Else
Set p = Union(p, c)
End If
End If
Next c
'get values
p.Offset(, -1).Copy Destination:=ws.Range("N" & Rows.Count).End(xlUp).Offset(1)
next i
The key error in your code is the idea that you might collect a range of non-consecutive cells and paste their value into a contiguous range. Excel can't do that. My code below collects qualifying values into an array and pastes that array into the target range.
The code below can't be exactly what you want because you didn't provide some vital information. However, please try it anyway with the aim of adapting it to your project.
Private Sub Review()
Dim Ws As Worksheet
Dim Rng As Range
Dim Rl As Long ' last row in column E
Dim Ary() As String
Dim Arr As Variant
Dim n As Long
Dim Cell As Range
Dim i As Long
Set Ws = Worksheets("Sheet1")
Ary = Split("C,F,B,PC,PB", ",") ' this array would be 0-based
Rl = Cells(Rows.Count, "E").End(xlUp).Row ' Range("E:E") has 1.4 million cells
Set Rng = Range(Cells(2, "E"), Cells(Rl, "E"))
For i = 0 To UBound(Ary)
ReDim Arr(1 To Rl)
n = 0
For Each Cell In Rng
If Cell.Value = Ary(i) Then
n = n + 1
Arr(n) = Cell.Offset(0, 1).Value
End If
Next Cell
If n Then
ReDim Preserve Arr(n)
'get values
Ws.Cells(Ws.Rows.Count, "N").End(xlUp).Offset(1) _
.Resize(UBound(Arr)).Value = Arr ' Application.Transpose(Arr)
End If
Next i
End Sub
This code works entirely on the ActiveSheet and then pastes the result to another sheet, named as "Sheet1". That isn't good practice. The better way would be to declare variables for both sheets and let the code refer to the variables so as to ensure that it has full control of which sheet it's working on at all times.
Set p = Union(p, c) will never be executed because it will only occur if p is NOT nothing, and Set p = Nothing is executed each time the outer loop iterates.
I have been stuck on this for weeks and have tried many formula combinations but can't get this to work. I don't know VBA so don't know where to start there.
I have List 1 and List 2 below. I need List 3 to be created from the data in Lists 1 and 2. List 3 can, preferably, be created in a new sheet.
I need to lookup the criteria from Column A, in List2 (Column D) then return all matches in a new list that shows: List 1; the criteria (Column A), data in Column B; and all matches from List 2 (Column E)
See Below. List 3 is the outcome
I broke this into two parts and I tried using a formula that copied the row the amount of times that there was a match. Then I was going to copy paste or find some vba or formula to combine the table but I came to a dead end when I realized the they tables weren't sorted in the same order. I ended up with these two lists to combine
Tried this VBA
Getting this error
Try This.
Run the macro "Test"
The first parameter should be the range of your first list (Just the numbers)
The second parameter should be the range of your second list (Just the numbers)
OutputSheet should be the sheet you want to output the list on
You can also optionally set the output row and output column (It will start at A1 if you don't specify)
Sub CreateList(List1 As Range, List2 As Range, OutputSheet As Worksheet, Optional ORow As Long = 1, Optional OCol As Long = 1)
Dim c, d
For Each c In List1
For Each d In List2
If c = d Then
OutputSheet.Cells(ORow, OCol).Value = c.Value
OutputSheet.Cells(ORow, OCol + 1).Value = c.Offset(0, 1).Value
OutputSheet.Cells(ORow, OCol + 2).Value = d.Offset(0, 1).Value
ORow = ORow + 1
End If
Next d
Next c
End Sub
Sub Test()
With Sheets("Sheet1")
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
End With
End Sub
The code loops through each number in the first list, and then each number in the second list.
If the numbers are the same, it outputs the number, the item, and the price.
First it will check If 10 = 10 Then - output the number, output the text next to the number on the first list, and output the amount next to the number on the second list.
Then it increases the row by 1.
That's pretty much all there is to it - just make sure you specify the ranges properly and change the sheet references as needed.
If you have never used VBA before, you can open the window by pressing ALT+F11
Right click to the left side and select Insert -> Module
Paste the code into the right side.
Update the ranges on the following line so they match where your lists are:
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
You can then close the window and press ALT+F8 to open the Run Macro dialog.
Select Test and click Run
Input:
Results:
What about this?
The code below assumes that on Sheet1, data starts from Row2 where Row1 is the header row.
Sub CreateList()
Dim x, y, z()
Dim i As Long, j As Long, k As Long, n As Long, dlr As Long
Dim wsData As Worksheet, wsOutput As Worksheet
Application.ScreenUpdating = False
Set wsData = Sheets("Sheet1")
On Error Resume Next
Set wsOutput = Sheets("List")
wsOutput.Cells.Clear
On Error GoTo 0
If wsOutput Is Nothing Then
Sheets.Add(after:=wsData).Name = "List"
Set wsOutput = ActiveSheet
End If
x = wsData.Range("A1").CurrentRegion.Value
y = wsData.Range("D1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
If Application.CountIf(wsData.Columns("D"), x(i, 1)) > 0 Then
n = Application.CountIf(wsData.Columns("D"), x(i, 1))
ReDim z(1 To n)
k = 1
For j = 2 To UBound(y, 1)
If y(j, 1) = x(i, 1) Then
z(k) = y(j, 2)
k = k + 1
End If
Next j
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
wsOutput.Range("A" & dlr).Value = x(i, 1)
wsOutput.Range("B" & dlr).Value = x(i, 2)
wsOutput.Range("C" & dlr).End(3)(2).Resize(UBound(z, 1), 1) = Application.Transpose(z)
End If
Erase z
Next i
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
If dlr > 1 Then
wsOutput.Range("A2:C" & dlr).CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
wsOutput.Rows(1).Delete
End If
Application.ScreenUpdating = True
End Sub
Assume Column B has data such as Data1/Data2/Data3-1/Data3-7 - all other rows have various data.
I need to take each row that has that Column B (some may not) and create 1 row for each individual value, with every other piece of data in the row copied for all of them.
Data may have symbols, dashes, and other random stuff, but the actual data itself will not have a / in it, only / is used to designate split lines
Any1 know the best way to do this? Excel 07 and OO available.
Is a VBA solution OK?
Sub DuplicateRows()
Dim r As Range
Set r = Cells(Rows.Count, 2).End(xlUp)
Do While r.Row > 1
TestRow r
Set r = r.Offset(-1, 0)
Loop
TestRow r
End Sub
Sub TestRow(r As Range)
Dim i As Long, n As Long
Dim a() As String
i = InStr(r, "/")
If i > 0 Then
n = Len(r) - Len(Replace(r, "/", ""))
r.EntireRow.Copy
r.Offset(1, 0).Resize(n).EntireRow.Insert Shift:=xlDown
a = Split(r, "/")
For i = 0 To n
r.Offset(i, 0) = a(i)
Next
End If
Application.CutCopyMode = False
End Sub