Sub MoveRowtoAnotherTab()
'Created by Ruchita Rane
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Contact").UsedRange.Rows.Count
B = Worksheets("Lead Created").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Lead Created").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Contact").Range("C1:C" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(A).Value) = "1" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Lead Created").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
My variable is K=1 to move the row from one sheet to another and I do not want to erase data in Contact. I am not good in VBA, Can someone please help?
I think you needed to change A to C in line If CStr(xRg(A).Value) = "1" Then
Option Explicit
Sub MoveRowtoAnotherTab()
'Created by Ruchita Rane
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Contact").UsedRange.Rows.Count
B = Worksheets("Lead Created").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Lead Created").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Contact").Range("C1:C" & A)
'On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "1" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Lead Created").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Related
Sub fadfadsf()
'Declare variables
Dim DataRg As Range
Dim DataCell As Range
Dim P As Long
Dim J As Long
Dim I As Long
'Set variables
P = Worksheets("EquipOtherPortfolio").UsedRange.Rows.Count
Q = Worksheets("Modifiedby RDS_EquipmentOther").UsedRange.Rows.Count
''Type If condition to relate the variables I and Q
If I = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Modifiedby RDS_EquipmentOther").UsedRange) = 0 Then Q = 0
End If
'Set range for Dataset1
Set DataRg = Worksheets("EquipOtherPortfolio").Range("J2:J2" & P)
On Error Resume Next
Application.ScreenUpdating = False
'Apply the For loop
For I = 1 To DataRg.Count
'Set Condition for "" value
If CStr(DataRg(I).Value) = "Files" Then
- - '**Apply command to copy cells ' When I change **"A" to "A10"** it will not show any resluts not sure where is the disconnect.**
DataRg(I).EntireRow.Range("I1:N1").Copy Destination:=Worksheets("Modifiedby RDS_EquipmentOther").Range("A" & Q + 1)
Q = Q + 1
End If
Next
Application.ScreenUpdating = True
End Sub
In apply command to copy cell section I tried changing "A" to "A10" but is not showing me results and could not figured out how to change variables.
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?
I tried this, which returned the rows I want, so a good start. But I really just need the value in Column B, not the entire row. What I really want is to list the value in column B if the value in column C is <>"" and column D <>"". Results in Quote sheet starting in cell C4.
Sub CopyQuoteValues()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Software Options").UsedRange.Rows.Count
B = Worksheets("Quote").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Quote").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Software Options").Range("C17:C" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) <> "" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Quote").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Something like this should do what you need:
Sub CopyQuoteValues()
Dim wsOpt As Worksheet, wsQuote As Worksheet
Dim c As Range, rngDest As Range
Set wsOpt = Worksheets("Software Options")
Set wsQuote = Worksheets("Quote")
Set rngDest = wsQuote.Range("C4")
For Each c In wsOpt.Range("C17", wsOpt.Cells(wsOpt.Rows.Count, "C").End(xlUp)).Cells
If Len(c.Value) > 0 And Len(c.Offset(0, 1)) > 0 Then 'value in C and D ?
c.Offset(0, -1).Copy rngDest 'copy ColB
Set rngDest = rngDest.Offset(1, 0) 'next paste location
End If
Next c
End Sub
Very new to this but enjoying the journey.
I am trying to populate a cell then click a button to run the macro. Problem is I have the code all working if I include the cells value in the code.....
Sub CopyRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Sheet1").UsedRange.Rows.Count
B = Worksheets("Sheet2").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Sheet1").Range("C1:C" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "ASML" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
But I want "ASML" not to be constant. I need it to be variable (ie the value of cell K1)
I am sure it is a simple fix but not very good at this
Bosnia
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