I'm having trouble with some VBA code and was hoping that someone could help me out.
The problem is with me referencing a specific cell. The code below copies rows into another worksheet and deletes them in the worksheet it took them from based on a value.
The issue is that I want the user to be able to specify the value in a specific cell rather than coming back to a spreadhseet to alter and realter it (it's just a quality of life thing).
Here's the code and what I mean:
Sub Kappa()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Data").UsedRange.Rows.Count
J = Worksheets("Archives").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archives").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Data").Range("I1:I" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Application.Workbooks("Book1.xlsm").Worksheets("Data").Range("M5") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archives").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = Application.Workbooks("Book1.xlsm").Worksheets("Data").Range("M5") Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True End Sub
What happens with this is that it spins (I couldn't even get an error!).
If you alter the code to say something along the lines of:
Sub Kappa()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Data").UsedRange.Rows.Count
J = Worksheets("Archives").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Archives").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Data").Range("I1:I" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Alpha" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Archives").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Alpha" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True End Sub
It works like a charm.
Is there any way of repurposing this so it references a value in a cell?
Related
I am wondering if anyone can help me. I am using a macro to move information from one sheet to another once sold. The problem is that the new sheet has built-in formulas to auto-populate data when items are added. I was wondering if there is a way to still use the macro but have the row be moved over to the new sheet but have it ignore the formulas. Right now it moves the rows to the row after the last formula cell.
The Current code I am using is:
Sub Sold()
'Updated by Kutools for Excel 2017/8/28
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Open Inventory").UsedRange.Rows.Count
J = Worksheets("Sold").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sold").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Open Inventory").Range("H1:H" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Sold" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sold").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Sold" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I have the below code which takes rows of data from one worksheet(DataSheet) that has "Actioned" in Column C and should paste it to the next available row on the worksheet (Actioned). The issue at hand is that it doesn't paste it on the next available row, its pasting to Row 2700.
I've cleared contents on all the cells and restarted the workbook but it still doesn't paste it onto the next free row.
can anyone see where I'm going wrong?
Dim xRg As Range
Dim xCell As Range
Dim i As Long
Dim J As Long
Dim K As Long
i = Worksheets("DataSheet").UsedRange.Rows.Count
J = Worksheets("Actioned").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Actioned").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("DataSheet").Range("C2:C" & i)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Actioned" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Actioned").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Actioned" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub ```
I am still a novice at VBA so please bare with my ignorance.
UsedRange can take into account the formatting of empty cells which is not visible to you.
I suggest to use the following method to get the last row of a specific column:
i= Worksheets("DataSheet").Range("C" & Worksheets("DataSheet").Rows.Count).End(xlUp).Row
or:
Dim wsDS As Worksheet: Set wsDS = Worksheets("DataSheet")
Dim iRows As Long
iRows = wsDS.Range("C" & wsDS.Rows.Count).End(xlUp).Row
I have a worksheet that I've made to track progress on projects. I currently have an active x button that when clicked it moves a row from the active worksheet (Project Tracker) to another worksheet (Released). The value that would trigger this action would be in column J (Released). This works perfectly.
I would like to have multiple worksheets that have the same names as the project names which are based on different companies that would be selected from a drop-down list (to stop typos). I need help on code to move the cut rows to these certain sheets.
Current code:
enter code here
Sub CommandButton1_Click()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
DIM T AS
I = Worksheets("PROJECT TRACKER").UsedRange.Rows.Count
J = Worksheets("RELEASED").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("RELEASED").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("PROJECT TRACKER").Range("L1:L" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "RELEASED" Then
xRg(K).EntireRow.Cut Destination:=Worksheets("RELEASED").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "RELEASED" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
his is cross-posted
https://www.excelguru.ca/forums/showthread.php?10476-Cut-and-Paste-a-row-in-one-sheet-to-another-based-on-a-cell-value
As a non-professional but research for accelerate data entry in excel, I've designed an Excel userform with 'split row and columns' for each 'Actors' and 'Paxs' textboxes. With initial input, the entry was fine but when repeat, the information overwritten the recent ones. I've no knowledge to adjust such overwriting. Do I miss something there? advise,please.
Private Sub cmdIn_Click()
Dim RowCnt As Long
Dim Actors As Variant
Dim ColNum1 As Variant
Dim j As Integer
Dim Paxs As Variant
Dim ColNum2 As Variant
Dim k As Integer
Dim ws As Worksheet
Set ws = Worksheets("ActPaxs")
RowCnt = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
RowCnt = 2
Actors = Split(Me.TxtActors.Value, vbCrLf)
For Each r In Actors
j = 1
ColNum1 = Split(r, ", ")
For Each c In ColNum1
ws.Cells(RowCnt, j).Value = c
j = j + 1
Next c
RowCnt = RowCnt + 1
Next r
RowCnt = 2
Paxs = Split(Me.TxtPaxs.Value, vbCrLf)
For Each p In Paxs
k = 4
ColNum2 = Split(p, ", ")
For Each q In ColNum2
ws.Cells(RowCnt, k).Value = q
k = k + 1
Next q
RowCnt = RowCnt + 1
Next p
TxtActors.Text = ""
TxtPaxs.Text = ""
End Sub
How to repeat same code to add more data and not overwrite the existing ones?
RowCnt = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
RowCnt = 2
delete the second instance which hard codes to row 2, the first instance detects the last used row and offsets by 1
Edit: you have another instance of RowCnt = 2 further down in the code, delete that too.
I have a range A6:A24 that is blank. I want to paste the value 1 into each cell and copy a resulting calculation in H9 to a new sheet. After that I want to move to the next cell paste "1" but delete the previous "1" and paste the resulting value.
I am either able to paste 1 into every box or just the top.
A6:A24 are years. I am trying to pull the calculation for when each year is equal to 1 (100 percent) meaning all other years need to be equal to zero.
Private Sub CommandButton1_Click()
Dim inputRange1 As Range
Dim inputRange2 As Range
Dim c As Range
Dim i As Long
Dim b As Range
Dim j As Long
Set dvCell2 = Worksheets("Sheet1").Range("A6:A24")
Set inputRange2 = Worksheets("Sheet1").Range("D1")
Set dvCell1 = Worksheets("Sheet2").Range("C1")
Set inputRange1 = Worksheets("Sheet1").Range("B6:B24")
i = 1
j = 1
Application.ScreenUpdating = False
For Each b In inputRange2
dvCell2.Value = b.Value
For Each c In inputRange1
dvCell1.Value = c.Value
Worksheets("Sheet4").Cells(i + 2, j + 3).Value = Worksheets("Sheet3").Range("H9").Value
i = i + 1
Next c
j = j + 1
i = 1
Next b
Application.ScreenUpdating = True
End Sub
Not sure I follow. This will loop through each cell in dvcell2 and put a 1 in it and then copy the value of H9. I'm not sure if you're attempting to do something else.
Private Sub CommandButton1_Click()
Dim inputRange1 As Range
Dim inputRange2 As Range
Dim c As Range
Dim i As Long
Dim b As Range
Dim j As Long
Set dvcell2 = Worksheets("Sheet1").Range("A6:A24")
Set inputRange2 = Worksheets("Sheet1").Range("D1")
Set dvCell1 = Worksheets("Sheet2").Range("C1")
Set inputRange1 = Worksheets("Sheet1").Range("B6:B24")
i = 1
j = 1
Application.ScreenUpdating = False
For Each b In dvcell2
dvcell2.value=0
b.Value = 1
Worksheets("Sheet4").Cells(i + 2, j + 3).Value = Worksheets("Sheet3").Range("H9").Value
j = j + 1
Next b
Application.ScreenUpdating = True
End Sub