Select two noncontiguous cells

[stickflipper]

I need to write a macro that will find, select two different cells then swap the contents of those cells.
I already have the macro that will swap the cells, what I need help with is selecting the cells.
The second cell is always 2 row down from the first.

i.e.
A3: xyz
A4: bdc
A5: 123

I want to select A3 and A5 via VBA so the swap macro can do it's thing.

I am lost, and floundering, I have tried several different things and rather than distract with my off the wall ideas thought I would ask what would be the best way to accomplish this.
Thanks
Rick

 

[ZVI]

Hi Rick,
Try something like this:

Sub Test()
 
  Dim FirstCell As Range, SecondCell As Range
  Dim TempValue
 
  Set FirstCell = Range("A3")           ' Write address of the cell here. Alternative: Set FirstCell = ActiveCell
  Set SecondCell = FirstCell.Offset(2)  ' The cell two rows down relative to the FirstCell 
 
  TempValue = FirstCell.Value         ' Save value of the first cell
  FirstCell.Value = SecondCell.Value  ' Copy value of the SecondCell to the FirstCell
  SecondCell.Value = TempValue        ' Copy saved value of the FirstCell to the SecondCell
  
End Sub

Regards

 

[stickflipper]

Thank You, that got me started. I have it so it finds the value, swaps the cells, then offsets so I can execute the macro again without stepping on the cells that were just swapped. Next is getting it to step through the sheet and do all the work while I watch

Thanks again.

Rick

 

[ZVI]

Good to know it helped a bit
Post back if you get any problems

 

[stickflipper]

The works awesome, but I can't figure out how to make it loop through the populated cells in column A.
It's kicked me around long enough, any help is greatly appreciated.

Rick

Sub swapcbrows()


    Dim FirstCell As Range, SecondCell As Range
    Dim TempValue


    Cells.Find(what:="<cb cbtype*="" cb="">", after:=ActiveCell, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate


      
    Set FirstCell = ActiveCell            ' Write address of the cell here. Alternative: Set FirstCell = ActiveCell
    Set SecondCell = FirstCell.Offset(2)  ' The cell two rows down relative to the FirstCell
 
    TempValue = FirstCell.Value         ' Save value of the first cell
    FirstCell.Value = SecondCell.Value  ' Copy value of the SecondCell to the FirstCell
    SecondCell.Value = TempValue        ' Copy saved value of the FirstCell to the SecondCell
    
    ActiveCell.Offset(3, 0).Select
    


End Sub

</cb>

 

[ZVI]

Try using of array (read details in comments of the code):

Sub SwapValues()
' Select cell in A-column and run this macro
' It swaps the current value with two rows down value (with further steps on 4 rows down)
'
' For speed reason:
'  1. Range is defined in A-column from the active cell's row up to the last nonempty cell in A-column
' `2. Values are copied from the range Rng to the array variable a(),
'  3. Swapping are made in array
'  4. Swapped values of array a() are copied back to the same range Rng
 
  Dim a(), v
  Dim i As Long
  Dim Rng As Range
 
  ' Copy values of A column from the activecell up to the last cell into the a() variable
  Set Rng = Range(ActiveCell.EntireRow.Columns("A"), Cells(Rows.Count, "A").End(xlUp))
  a() = Rng.Value
 
  ' Swap values
  For i = 1 To UBound(a) Step 4
    v = a(i, 1)
    a(i, 1) = a(i + 2, 1)
    a(i + 2, 1) = v
  Next
 
  ' Copy back values of array a() to the range
  Rng.Value = a()
 
End Sub

 

[ZVI]

Code of this version firstly searches the starting nonempty value in array,
other functionality is the same as in previous code.

Sub SwapValues1()
' Select cell in A-column and run this macro
' It swaps the 1st nonemty value with value two rows down (with further steps in a loop on 4 rows down)
'
' For speed reason:
'  1. Range is defined in A-column from the active cell's row up to the last nonempty cell in A-column
'  2. Values are copied from the range Rng to the array variable a(),
'  3. Position of nonemty value is seached in a()
'  4. Swapping are provided in array startin from the found position (see point 3)
'  5. Swapped values of array a() are copied back to the same range Rng
 
  Dim a(), v
  Dim i As Long, j As Long
  Dim Rng As Range
 
  ' Copy values of A column from the activecell up to the last cell into the a() variable
  Set Rng = Range(ActiveCell.EntireRow.Columns("A"), Cells(Rows.Count, "A").End(xlUp))
  a() = Rng.Value
 
  ' Find the first nonempty value in array
  For j = 1 To UBound(a)
    If Len(a(j, 1)) > 0 Then Exit For
  Next
 
  ' Swap values
  For i = j To UBound(a) Step 4
    v = a(i, 1)
    a(i, 1) = a(i + 2, 1)
    a(i + 2, 1) = v
  Next
 
  ' Copy back values of array a() to the range
  Rng.Value = a()
 
End Sub

 

[stickflipper]

I appreciate the help, I keep getting a "run-time error '9': Subscript out of range. debug highlights

a(i, 1) = a(i + 2, 1)

This is after the macro has run once, on the second execution is when it faults. When it does run, it's not swapping the correct two cells.


I got this to work but it stops after processing 15 rows, I'm confused NumRows has issues and is not returning the range I am needing? The files all have empty text cells after the populated cells. I would like to be able to call the macro from another macro.

Sub swapcbrows1()


    Dim x As Integer


    Dim FirstCell As Range, SecondCell As Range
    Dim TempValue


    NumRows = Range("A3", Range("A3").Cells.SpecialCells(xlCellTypeBlanks)).Rows.Count
      
    For x = 1 To NumRows


    Cells.Find(what:="<cb cbtype*/cb>", after:=ActiveCell, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
      
    Set FirstCell = ActiveCell            ' Write address of the cell here. Alternative: Set FirstCell = ActiveCell
    Set SecondCell = FirstCell.Offset(2)  ' The cell two rows down relative to the FirstCell
 
    TempValue = FirstCell.Value         ' Save value of the first cell
    FirstCell.Value = SecondCell.Value  ' Copy value of the SecondCell to the FirstCell
    SecondCell.Value = TempValue        ' Copy saved value of the FirstCell to the SecondCell
    
    ActiveCell.Offset(4, 0).Select
    
    Next x


End Sub

Rick

 

[ZVI]

I appreciate the help, I keep getting a "run-time error '9': Subscript out of range. debug highlights

a(i, 1) = a(i + 2, 1)

<cb cbtype*="" cb="">
Rick

My bad </cb><cb cbtype*="" cb="">
Here is the fixed code (changing parts are in red):
</cb>

Sub SwapValues2()
' Select cell in A-column and run this macro
' It swaps the 1st nonemty value with value two rows down (with further steps in a loop on 3 rows down)
'
' For speed reason: 
'  1. Range is defined in A-column from the active cell's row up to the last nonempty cell in A-column
'  2. Values are copied from the range Rng to the array variable a(),
'  3. Position of nonemty value is seached in a()
'  4. Swapping are provided in array startin from the found position (see point 3)
'  5. Swapped values of array a() are copied back to the same range Rng
 
  Dim a(), v
  Dim i As Long, j As Long
  Dim Rng As Range
 
  ' Copy values of A column from the activecell up to the last cell into the a() variable
  Set Rng = Range(ActiveCell.EntireRow.Columns("A"), Cells(Rows.Count, "A").End(xlUp))
  a() = Rng.Value
 
  ' Find the first nonempty value in array
  For j = 1 To UBound(a)
    If Len(a(j, 1)) > 0 Then Exit For
  Next
 
  ' Swap values
  For i = j To UBound(a) - 2 Step 3
    v = a(i, 1)
    a(i, 1) = a(i + 2, 1)
    a(i + 2, 1) = v
  Next
 
  ' Copy back values of array a() to the range
  Rng.Value = a()
 
End Sub

<cb cbtype*="" cb="">
</cb>