I am trying to copy rows onto three different sheets based on criteria in column AZ. I can get the first IF statement to work but the else ifs copy the information not in the first row of the designated sheet but where the previous sheet ended.
Here is what I have
Private Sub CommandButton1_Click()
Dim Cell As Range
With Sheets(2)
For Each Cell In .Range("AZ2:AZ" & .Cells(.Rows.Count, "AZ").End(xlUp).Row)
If Cell.Value = 1 Then
.Rows(Cell.Row).Copy Destination:=Sheets("2X4").Rows(Cell.Row)
ElseIf Cell.Value = 2 Then
.Rows(Cell.Row).Copy Destination:=Sheets("2X6").Rows(Cell.Row)
ElseIf Cell.Value = 3 Then
.Rows(Cell.Row).Copy Destination:=Sheets("2X6H").Rows(Cell.Row)
End If
Next Cell
End With
End Sub
Picking up on #Marcucciboy2's comment you could use something like this.
Private Sub CommandButton1_Click()
Dim Cell As Range, v1, v2
v1 = Array("2X4", "2X6", "2X6H"): v2 = Array(2, 2, 2)
With Sheets(2)
For Each Cell In .Range("AZ2:AZ" & .Cells(.Rows.Count, "AZ").End(xlUp).Row)
If Cell.Value = 1 Or Cell.Value = 2 Or Cell.Value = 3 Then
.Rows(Cell.Row).Copy Destination:=Sheets(v1(Cell.Value - 1)).Range("A" & v2(Cell.Value - 1))
v2(Cell.Value - 1) = v2(Cell.Value - 1) + 1
End If
Next Cell
End With
End Sub
Related
I have in E, F and I columns something written. In E and F its a name and in I its a number. In I column there are some cells with number and rest are blank. When ever its a number, I should copy the names from E1, F1 and copy it to C3 and D3 respectively. I have written a code but its not functioning properly. Could you please help me.
Option Explicit
Sub copy()
Dim cell As Long
Dim nr As Integer
Dim rng As range
Dim i As Long
range("G1:G15").Select
Selection.CurrentRegion.Select
nr = Selection.Rows.Count
For i = 2 To nr
'test if cell is empty
If ActiveCell(i, 7) = "" Then
'write to adjacent cell
ActiveCell = ActiveCell + 1
Else
ActiveCell.Offset(-3, -2).Value.copy ActiveCell.Offset(-3, 0)
End If
Next i
End Sub
Option Explicit
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 2
Col = 9
Do Until Cells(Row, 5).Value = ""
If IsNumeric(Cells(Row, Col)) = True Then
Range("E" & Row & ":F" & Row).copy
Range("C" & Row).PasteSpecial (xlPasteValues)
End If
Row = Row + 1
Loop
Application.CutCopyMode = False
End Sub
Updated Question
I have a VBA script attached to sheet 1 that uses the B5:B50 cell values to populate the adjacent column with pre-defined text. If I want to use this script in another sheet, but still use the B5:B50 cell values of the previous sheet. How to I do that?
For Example:
In sheet 1, If I enter the value of 2 in the cell B5, it will populate D5 and E5 with the text value attached to CONST TXT. I want to do the same thing in sheet 2, but instead of the user entering the value again into B5 of sheet 2, it just gets the value of B5 from the previous sheet and then populate D5 and E5.
Sheet 2 B values will need to update as soon as the B values are updated in Sheet 1.
Private Sub Worksheet_Change(ByVal Target As Range)
Const NUM_COLS As Long = 5
Const TXT = "• Course Name:" & vbNewLine & _
"• No. Of Slides Affected:" & vbNewLine & _
"• No. of Activities Affected:"
Dim rng As Range, i As Long, v
If Target.CountLarge <> 1 Then Exit Sub
If Not Intersect(Target, Me.Range("B5:B50")) Is Nothing Then
Set rng = Target.Offset(0, 2).Resize(1, NUM_COLS) 'range to check
v = Target.Value
If IsNumeric(v) And v >= 1 And v <= NUM_COLS Then
For i = 1 To rng.Cells.Count
With rng.Cells(i)
If i <= v Then
'Populate if not already populated
If .Value = "" Then .Value = TXT
Else
'Clear any existing value
.Value = ""
End If
End With
Next i
Else
rng.Value = "" 'clear any existing content
End If
End If
End Sub
As I understand you, you want something like an equivalent of offset which returns a range on a different sheet. There are a couple of options.
You can use Range.AddressLocal, which returns the address of Range without any worksheet or workbook qualifiers, and then apply this to the other worksheet:
'returns a cell 1 to the right of rng, but on Sheet2
Worksheets("Sheet2").Range(rng.Offset(0, 1).AddressLocal)
Or you can get the Row and Column properties of your range and use them in Cells in the other worksheet:
'returns a cell 1 to the right of rng, but on Sheet2
Worksheets("Sheet2").Cells(rng.Row, rng.Column + 1)
To use it in your code, I think it's just a case of replacing
If .Value = "" Then .Value = TXT
with
If Worksheets("Sheet2").Range(.Offset(0, 1).AddressLocal).Value = "" Then Worksheets("Sheet2").Range(.Offset(0, 1).AddressLocal).Value = TXT
and replacing
.Value = ""
with
Worksheets("Sheet2").Range(.Offset(0, 1).AddressLocal).Value = ""
(or the same using the Cells construction).
The below will copy the Target.Value into the same cell in Sheet2
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
If Not Intersect(Target, Me.Range("B5:B50")) Is Nothing And Target.Count = 1 Then
With Target
ws2.Cells(.Row, .Column).Value = .Value
End With
End If
End Sub
I have the following spreadsheet. When ever there is an x in cell B I need to populate the d and e cells in the same row using an equation I have.
if there is no x in the b cell I need to manually enter values into cells d & e.
How do I make my code non-row specific?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim val As String
val = Range("B3").Value
If val = "x" Then
Range("E3").Value = Range("d2").Value * Range("G2").Value
Range("D3").Value = Range("D2").Value
End If
End Sub
I'm not sure if I understand correctly, but if you have a parameter: row = 3 you can use Range("E" & row) instead of Range("E3").
Put a loop around that where you vary 'row' for the rows you want to modify.
Hope that helps!
You've created a sub procedure around the Worksheet_SelectionChange event. In fact, you require Worksheet_Change and you need to,
disable event handling so you can write new values/formulas to the worksheet without running the Worksheet_Change on top of itself.
loop through each matching cell in Target to compensate for circumstances when Target can be more than a single cell,
add error control.
Rewrite:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Range("B:B"))
If LCase(t.Value) = "x" Then
'I've made these formulas relative to each target
'you may want to make some absolute references
t.Offset(0, 3) = t.Offset(-1, 2) * t.Offset(-1, 5)
t.Offset(0, 2) = t.Offset(-1, 2)
Else
t.Offset(0, 2).resize(1, 2) = vbnullstring
End If
Next t
End If
safe_exit:
Application.EnableEvents = True
End Sub
Please try below code.
It loop through all non empty rows in column B and check if there is value: x
If so it populate your formulas.
Sub new_sub()
' get last_row of data
last_row = ActiveSheet.UsedRange.Rows.Count
' loop through all rows with data and check if in column B any cell contains value: x
For i = 1 To last_row
' if there is any cell with value: x
' then add below formulas
If Cells(i, 2).Value = "x" Then
' for column E: take value from row above for col D and G and multiple
Range("E" & i).Value = Range("d" & i - 1).Value * Range("G" & i - 1).Value
' for column D: take value from row above
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
End Sub
I want to run a macro on selected cells - where the macro compares a cell to it's neighbor beneath him - changes their color and moves on to the next pair of cells.
it's A 1 dimension array where I want to compare each pair of cells (1st with the 2nd, 3rd with the 4th etc.)
I tried working with
For Each cell In Selection
but then I don't know how to compare the given cell to the one beneath it.
Below is the sample code.
Sub compare()
Dim rng As Range, cell As Range
Set rng = Selection '
For Each cell In rng
'makes comparison
'offset(1,0) is used to find one cell below active cell
If cell.Value = cell.Offset(1, 0) Then
cell.Offset(1, 0).Interior.Color = vbRed
End If
Next
End Sub
Updated answer
Sub compare()
Dim rows As Long
rows = Selection.rows.Count - 1
Dim selCol As Long
selCol = ActiveCell.Column
Dim selRow As Long
selRow = ActiveCell.Row
For i = selRow To (selRow + rows)
If Cells(i, selCol) = Cells(i, selCol + 1) Then
Range(Cells(i, selCol), Cells(i, selCol + 1)).Interior.Color = vbYellow
End If
Next
End Sub
Sub compareCells()
Dim i As Integer
'Check dimension
If Selection.Columns.Count <> 1 Then
MsgBox "not 1d array"
Exit Sub
End If
'Check size
If Selection.Rows.Count Mod 2 <> 0 Then
MsgBox "size not even"
Exit Sub
End If
For i = 1 To Selection.Count / 2
With Selection
If .Cells(2 * i - 1) = .Cells(2 * i) Then
'what you want to do here, for e.g. , change color
.Cells(2 * i).Interior.Color = vbYellow
Else
'what you want to do here
'MsgBox "neq"
End If
End With
Next i
End Sub
How can I create a macro that will add a day in one cell and subtract a day in another cell at the same time? Here is what I have so far.
Sub ChangeDates()
Dim cell As Range
For Each cell In Range("B:B")
cell.Value = cell.Value + 1
Next cell
For Each cell In Range("C:C")
cell.Value = cell.Value - 1
End Sub
I know you've accepted an answer, but I would like to offer this approach, which is even faster and more efficient than looping through all those cells.
If your dates are in Column A, then Column B will hold date +1 and Column C will hold date -1
Option Explicit
Sub ChangeDates()
Dim myRange As range
Dim mySheet As Worksheet
Set mySheet = Sheets("Sheet7") 'change to your sheet
With mySheet
Set myRange = .range("A1:A" & .range("A" & .Rows.Count).End(xlUp).Row)
myRange.Offset(, 1).FormulaR1C1 = "=RC[-1]+1"
myRange.Offset(, 2).FormulaR1C1 = "=RC[-2]-1"
End With
End Sub
Offset to the rescue!!
Sub ChangeDates()
Dim cell As Range
For Each cell In Range("B:B")
cell.Value = cell.Value + 1
cell.offset(0,1).value = cell.offset(0,1).value - 1
Next cell
End Sub
Another thing you may consider is either looking at usedrange to not have to iterate through all of column B or put in a check to make sure the cells aren't blank... Just faster, better coding and stops you from having bad values where the cells were originally blank...
Sub ChangeDates()
Dim cell As Range
For Each cell In Intersect(Range("B:B"), ActiveSheet.UsedRange)
cell.Value = cell.Value + 1
cell.Offset(0, 1).Value = cell.Offset(0, 1).Value - 1
Next cell
End Sub