How to Code change on moving cell contents down one

How to code change on moving cell contents down one

Requirement:

The user needs help with a change to code. Currently it moves two cells of numbers (side by side) to the cell directly below it. I need it changed to move only the first cell down (in the cell range E5:E14 sample). The user does not need the code to delete the cell contents to the right of it (cell range F5:F14 sample). There could be one of more sets of numbers in the cell rage (in the sample there are two sets and both have to be moved down by one cell).

This is only a sample sheet and so please don’t hard code the code. The user needs to be able to change the cell locations in the code. The user has attached a sample Excel workbook with the expected result (please refer to the link below to gain access to the forum to obtain the file).

Code:

Sub MOVE1DOWN()

Dim n, sht As Worksheet, cell As Range, num, tmp, rngDest As Range

Set sht = ActiveSheet

n = sht.Range("J2")

For Each cell In sht.Range("E5:E14").Cells

tmp = cell.Offset(0, 1).Value

If cell.Value = n And tmp Like "*#-#*" Then

'get the first number

num = CLng(Trim(Split(tmp, "-")(0)))

Debug.Print "Found a positive result in " & cell.Address

'find the next empty cell in the appropriate row

Set rngDest = sht.Cells(num, sht.Columns.Count).End(xlToLeft).Offset(0, 1)

If rngDest.Column < 10 Then Set rngDest = sht.Cells(num, 10)

cell.Offset(0, 1).Copy rngDest

Rem Move the next row of cell contents to the next cell

In sht.Range(“F5:F14”).Cells

tmp = cell.Offset(0, 1).Value

If cell.Value = n And tmp Like "*#-#*" Then

Cells(irow + 1, icol).Insert Shift:=xlDown

Cells(irow, icol).Copy Cells(irow + 1, icol)

Cells(irow, icol).Clear

Exit For

End If

Next

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1215951-code-change-on-moving-cell-contents-down-one

Solution:

Code:

Sub MoveDownOne()
Dim cell As Range
Dim num1 As Long
Dim num2 As Long

  For Each cell In Range("E5:E14")
      If cell.Value Like "*#-#*" Then
        num1 = CLng(Trim(Split(cell.Value, "-")(0)))
        num2 = CLng(Trim(Split(cell.Value, "-")(1))) + 1
        cell.Value = num1 & "-" & num2
      End If
  Next cell
    Range("E5:E13").Cut
    Range("E6").Select
    ActiveSheet.Paste
    Range("E5").Select
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by Carim.