My code is really simple:
Dim j As Long
Dim k As Long
k = 2
For i = 0 To PatientList.ListCount - 1
If PatientList.Selected(i) = True Then
Worksheets("Print").Range("B" & k).Value = 1
k = k + 1
End If
Next i
Unload Me
For some reason, if I remove the line that contains (Worksheets.......) and have a multiselected listBox the k variable is incremented normally and all is fine.
If I add the aforementioned line, the program goes through the cycle once as if only one line on the listbox is selected. The k variable is not incremented and setting toggle shows that the program doesn't not recognize the multiselection, but only the first choice.
Any ideas?
This is very odd and I tested on different PCs....
since it seems your ListBox RowSource value is influenced by any change of "Print" worksheet, you could collect the range to be copied/pasted and do the copy/paste operation at the end
Dim i As Long
Dim k As Long
k = 2
Dim rngToBeCopied As Range ' range to collect cells to copy
For i = 0 To PatientList.ListCount - 1
If PatientList.Selected(i) = True Then
' update range to be copied
If rngToBeCopied Is Nothing Then
Set rngToBeCopied = Worksheets("Source").Cells(k, 1)
Else
Set rngToBeCopied = Union(rngToBeCopied, Worksheets("Source").Cells(k, 1))
End If
k = k + 1
End If
Next i
' if any range to copy, then paste it to "Print" worksheet
If Not rngToBeCopied Is Nothing Then rngToBeCopied.Copy Worksheets("Print").Range("B1").Resize(rngToBeCopied.Count)
Me.Hide ' hide UserForm
' Unload Me ' move 'Unload' statement in the sub that has created/shown the Userform
just change Worksheets("Source").Cells(k, 1) to the proper sheet and range reference you actualy need
Related
I have written a short VBA code to copy rows from one worksheet "Quote Tracker", to another sheet "Cashflow", once a certain value has been selected in Column "O" (75 - 100%).
The issue I am having is that the rows are not copied into the next available empty row, only further down the sheet. I am also unable to stop the code copying the same line multiple times.
Is there anything I can add to ensure they are always added to the top of the "Cashflow" sheet or next available row?
I am also unable to put anything together to detect duplicates, so if the code is run more than once, it just keeps adding them to the "Cashflow sheet". Can anything be added to stop this?
Here is what I have so far:
Sub MoveRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Quote Tracker").UsedRange.Rows.Count
J = Worksheets("Cashflow").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Cashflow").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Quote Tracker").Range("O1:O" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "75 - 100%" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Cashflow").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Jobs copied to Cashflow tab"
End Sub
If you require more information, please, just let me know. I'm new here and trying to make a good impression.
I have compiled a sub that will suit your needs. The first issue I saw was your use of "On Error resume Next". This will make it nearly impossible to debug your code because the code will not tell you if there is an error it will simply skip over it. The second issue I was able to see was that you made the problem more complex than necessary. You used a For To loop where a For Each loop would get the job done more easily. I have added in a piece of code which makes the cell in the "P" column of the row with a value over 75% "Transferred" once it has been copied to the "Cashflow" sheet. The code also checks if "Transferred" is present in that column and if it is, it skips that value. Additionally, the code checks if J is 1 which would be the first value copied, and if it is not one then it adds one to the counter so that it does not paste on top of the row above.
Sub MoveRowBasedOnCellValue()
Dim QTWs As Worksheet
Dim CWs As Worksheet
Set QTWs = Worksheets("Quote Tracker")
Set CWs = Worksheets("Cashflow")
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = QTWs.UsedRange.Rows.Count
J = CWs.Cells(Rows.Count, "O").End(xlUp).Row
If J <> 1 Then
J = J + 1
End If
Set xRg = QTWs.Range("O1:O" & I)
Application.ScreenUpdating = False
For Each c In xRg
K = c.Row
If c.Value < 0.75 Then
'Do Nothing
Else
If QTWs.Cells(K, 16) <> "Transferred" Then
QTWs.Rows(K).Copy Destination:=Worksheets("Cashflow").Range("A" & J)
QTWs.Cells(K, 16).Value = "Transferred"
J = J + 1
Else
'Do Nothing
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "Jobs copied to Cashflow tab"
End Sub
If you have questions about how it works, do not hesitate to let me know. Hope this helps!
I have a set of information in the same column (H27:O27) in one sheet ("P1-FR1") and would like to paste individual values to another sheet (AQ6:AX6) ("Übersicht GESAMT")
I'm trying to use a For loop but the values just copy one after the other (in the same cell) instead of copying one in each cell. This is my code:
Sub CopyValues()
Dim i As Long
Dim j As Long
Dim Wert As Long
For i = 8 To 14
Wert = Sheets("P1-FR1").Cells(27, i)
For j = 43 To 50
Sheets("Übersicht GESAMT").Cells(6, j) = Wert
Next j
Next i
End Sub
You don't need a double For loop in this case at all. A simple .Value copy will work. The code below shows two examples with different ways to accomplish what you want. (TIP: it always helps me to be VERY clear on how I name the variables, it helps to keep track of where all the data is coming and going)
Option Explicit
Sub CopyTheValues()
Dim datenQuelle As Range
Dim datenZiel As Range
Set datenQuelle = ThisWorkbook.Sheets("P1-FR1").Range("H27:O27")
Set datenZiel = ThisWorkbook.Sheets("Übersicht GESAMT").Range("AQ6:AX6")
'--- method 1 - works because the ranges are the same size and shape
datenZiel.Value = datenQuelle.Value
'--- method 2 - for loops
' index starts at 1 because the Range is defined above
' (and we don't care what rows/columns are used)
Dim j As Long
For j = 1 To datenQuelle.Columns.Count
datenZiel.Cells(1, j).Value = datenQuelle.Cells(1, j).Value
Next i
End Sub
Copying By Assignment
Option Explicit
Sub CopyValuesNoLoop()
ThisWorkbook.Worksheets("Übersicht GESAMT").Range("AQ6:AX6").Value _
= ThisWorkbook.Worksheets("P1-FR1").Range("H27:O27").Value
End Sub
Sub CopyValuesQuickFix()
Dim j As Long: j = 43
Dim i As Long
For i = 8 To 14
ThisWorkbook.Worksheets("Übersicht GESAMT").Cells(6, j).Value _
= ThisWorkbook.Worksheets("P1-FR1").Cells(27, i).Value
j = j + 1
Next i
End Sub
The nesting of the for loops is causing your issue. It is causing each cell from the first sheet to be copied to all cells on the second sheet.
You only need one loop to perform the copy. Something like this should work.
Sub CopyValues()
Dim i As Long
For i = 8 To 15
Sheets("Übersicht GESAMT").Cells(6,i+35) = Sheets("P1-FR1").Cells(27,i)
Next i
End Sub
I need to move a row's contents within Table1 (range A1:H24) to another Table2 (on a different sheet than Table1) based off the Table1's H-cell value.
Ex. If H24 = "Yes", paste entire row onto table2, delete from table 1.
The code deletes the data from Table1 and pastes it onto sheet2, but it pastes below the table getting lower with each time you run the module.
Sub Archive()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Inventory").UsedRange.Rows.Count
J = Worksheets("Archive").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Inventory").Range("H1:H" & J)
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Yes" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Yes" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
#medicinal_nut the code you mentioned is VERY similar to the code here.
You could have copied the code better by not replacing the I in the original code with the J in your code.
Set xRg = Worksheets("Inventory").Range("H1:H" & J)
IMHO, the code is doing what it is supposed to be doing because of the J=J+1.
It just inserts 1 new row below the last inserted row in your Archive sheet, otherwise, it would just overwrite the last-copied row with the newly copied row, which would be quite a waste, IMHO.
May be I don't understand your question, in which case, please state your question clearer. Or perhaps, you may be able to find a solution which might meet your needs, on the web page that I mentioned in the first line.
Edited 1 day later on 18JUL2021: to provide more understandable code for OP
Option Explicit
Sub Archive()
Dim HColumnRows As Range
Dim InventoryUsedRows As Long
Dim ArchiveUsedRows As Long
Dim HColumnCurrentRow As Long
InventoryUsedRows = Worksheets("Inventory").UsedRange.Rows.Count
'ArchiveUsedRows can be directly manipulated here to set pasting point
ArchiveUsedRows = Worksheets("Archive").UsedRange.Rows.Count
If ArchiveUsedRows = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then ArchiveUsedRows = 0
End If
Set HColumnRows = Worksheets("Inventory").Range("H1:H" & InventoryUsedRows)
On Error Resume Next
Application.ScreenUpdating = False
For HColumnCurrentRow = 1 To HColumnRows.Count
If CStr(HColumnRows(HColumnCurrentRow).Value) = "Yes" Then
'ArchiveUsedRows+n <- n can be changed to reset pasting point
HColumnRows(HColumnCurrentRow).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & ArchiveUsedRows + 1)
HColumnRows(HColumnCurrentRow).EntireRow.Delete
If CStr(HColumnRows(HColumnCurrentRow).Value) = "Yes" Then
HColumnCurrentRow = HColumnCurrentRow - 1
End If
'ArchiveUsedRows+n where n can be changed to reset pasting point
ArchiveUsedRows = ArchiveUsedRows + 1
End If
Next HColumnCurrentRow
Application.ScreenUpdating = True
End Sub
As you can see above, I have a table in a Excel sheet where indication A can have product 1, product 2 and so forth (The prods names are all different depending on the indication, this is just for simplicity!).
In my userform a similar format is presented. I want to basically match the indication name on my excel sheet with the indication name in my userform. If they match, then Product 11 gets A's Prod 1 name, Product 12 gets A's Prod 2 name and so forth.
I've tried the following, but I'm just starting using VBA so I'm sure it probably doesn't even make sense.
Dim code_ind As String
Dim sel_ind As String
Dim chkbx As Control
Dim labx As Control
Dim i As Integer
Dim col_value As Integer
Dim row_value As Integer
For i = 1 To 8
For j = 1 To 4
For row_value = 4 To 11
col_value = 0
Set chkbx = Me.Controls("seg_l_selInd_" & i)
Set labx = Me.Controls("seg_cb_selInd_" & i & j)
sel_ind = tWb.Worksheets("LALALA").Columns(2).Find(what:=chkbx)
If code_ind = sel_ind Then
labx.Name = tWb.Worksheets("LALALA").Cells(row_value, 3 + col_value)
col_value = col_value + 1
End If
Next row_value
Next j
Next i
Is there any way I can do this? I know I could just write the names manually, but I need my tool to be as flexible as possible. Ideally, if more information is added into the excel table, the userform will automatically update.
Please check the next way. I tried thinking your project in this way:
The form in the next example must be named frmChkBox. The check boxes on the form will have names like "CheckBox11", "CheckBox12" and so on, first digit after "CheckBox" string being the row and the next one the column. If you appreciate that your real situation will exceed one digit number for the row number, they can be separated by "_", or something else. You can also create the check boxes on the flay.
a. Please paste in the form code module the next code lines:
Option Explicit
Private ChkBColl As New Collection
Private ChkB() As New ChkBoxChClss
Private Sub UserForm_Initialize()
Dim ws As Worksheet, rng As Range, iRow As Long, iCol As Long
Dim ctrl As MSForms.Control, ext As String, arrUsed, k As Long
ReDim ChkB(32)
ReDim arrUsed(Me.Controls.count)
Set ws = Sheets("INDICATION-PRODUCT")
Set rng = ws.Range("B2:E9")
For iRow = 1 To 8
For iCol = 1 To 4
For Each ctrl In Me.Controls
If TypeOf ctrl Is MSForms.CheckBox Then
If IsError(Application.Match(ctrl.Caption, arrUsed, 0)) Then
ext = Right(ctrl.Caption, Len(ctrl.Caption) - 8)
If left(ext, 1) = iRow And Right(ext, 1) = iCol Then
ctrl.Tag = rng.cells(iRow, iCol).Address
ctrl.Caption = rng.cells(iRow, iCol).Value
arrUsed(k) = ctrl.Caption: k = k + 1
ChkBColl.Add ctrl, ctrl.Name
Set ChkB(k).chkBEvent = ctrl
End If
End If
End If
Next
Next iCol
Next iRow
End Sub
Public Sub DoSomething(chk As MSForms.CheckBox)
Dim ws As Worksheet
Set ws = Sheets("INDICATION-PRODUCT"): ws.Activate
If chk.Value = True Then
ws.Range(chk.Tag).Select 'do whatever needed with the cell...
Else
ws.Range("A1").Select
End If
End Sub
Each check box Tag will receive the associated cell address.
In order to automatically allocate the same event to all of them, a simple class wrapper (named `ChkBoxChClss') will be created. It will identify the clicked check box and send the object to a form sub, where to be processed as needed. Please, paste the next code in the class:
Option Explicit
Public WithEvents chkBEvent As MSForms.CheckBox
Private Sub chkBEvent_Change()
frmChkBox.DoSomething chkBEvent
End Sub
You can use the Public Sub DoSomething to deal with the check box being clicked. Now, clicking a check box, if its value is True the correspondent cell will be selected. If False, the "A1" cell will be selected. You can do whatever you need.
I was finally able to solve it!
The table I have on my worksheet (Image 1) has the indication column that corresponds to the indication values on my userform. For each indication, there are several products.
I want my tool to be as flexible as possible, so I needed to match the indication name and for each checkbox in my userform I would obtain it's name from the table.
For example: Indication A, Prod 1 = Prod 1 (Checkbox.Name = Cell(x,y))
This is the code that I'm using:
Dim code_ind As String
Dim sel_ind As String
Dim chkbx As Control
Dim labx As Control
Dim i As Integer
Dim j As Integer
Dim col_value As Integer
Dim row_value As Integer
For i = 1 To 8
Set chkbx = Me.Controls("seg_l_selInd_" & i)
sel_ind = tWb.Worksheets("INDICATION-PRODUCT").Columns(2).Find(what:=chkbx)
If chkbx = sel_ind Then
col_value = 0
While tWb.Worksheets("INDICATION-PRODUCT").Cells(i + 3, 3 + col_value) <> ""
For j = 1 To 4
Set labx = Me.Controls("seg_cb_selInd_" & i & j)
labx.Caption = tWb.Worksheets("INDICATION-PRODUCT").Cells(i + 3, 3 + col_value)
col_value = col_value + 1
Next j
Wend
End If
Next i
Does it make sense to you?
Is there any way to make my code more flexible? For example, I'm assuming there are 8 indications (i = 1 to 8), but realistically there could be more in the future.
I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range.
I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it.
Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub
Maybe something like this ?
Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")
For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i
For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub
I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5.
The second for i = 1 to 5 is to offset from column B to G.
The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.
This if I'm not wrong to get what you mean.
Here's another approach, just for a bit of variety.
Sub x()
Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long
Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range
With WorksheetFunction
Do Until .Count(r2) = r2.Count 'loop until output range filled
r = .RandBetween(1, 25) 'random output cell number
If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
If r2.Cells(r) = vbNullString Then 'if random cell empty
r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
i = i + 1
End If
End If
Loop
End With
End Sub