How to copy and paste a cell contents using VBA

Question

See below where it reads: The problem to solve.

Note: I have copy of my Excel spreadsheet at the bottom to better explain the following:

I have the following VBA program that locates a manually entered number:

Sub do_it()

n = [A1]

For Each cell In Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30")
If cell.Value = n And Range(cell.Address).Offset(0, 1) = "1-5" Then
MsgBox "Found a postivive result in " & cell.Address
End If
Next

End Sub

To briefly explain the above program (excel graphic below):

1) I enter a number, any number in cell A1. Lets say I choose the number 4.

2) I have 5 column locations and ranges where the number 4 could be located: A15:A30,C15:C30,E15:E30,G15:G30,I15:I30. Each column has a number 4 in it but only one has a value in the cell to the right of it.

So as an example when it finds a 4 in cell E21 and a value such as 1-5 (could be any set of numbers such as 7-5 or 10-19) it’s a positive result. If their was no value in F21 it would be negative and would continue searching for other 4’s until it found a positive result). The end so far.

The problem to solve (copy of my excel spreadsheet below:

My next part of this program is to copy and paste the contents of cell F21 (in the above example) to one of the following rows: K1,K2,K3,K4,K5,K6,K7,K8,K9,K10,K11 and K12.

In this example (contents from cell F21) would be copied and pasted to cell L1. What I require the program to do is to check the first number (1 from 1-5 in this case) and select the appropriate row (1 in this case). The program must always select the first number of the two numbers located in the cell. If the cell contents in F21 was 5-10 then the program would copy 5-10 to row 5 and paste into cell L5 and so on.

The next issue is to have the program copy and paste to a unique cell location each time it pastes. So to take the above example of 1-5 from cell F21 that was pasted into cell L1. The next time I enter a new number into the A1 box , lets say the number 5 and the program finds a positive result (G24 this time) and cell contents of H24 is 1-7 it copy and pastes 1-7 to cell M1 and not over-right the contents of cell L1. The paste function would continue always to the right of the previous copy and paste (in the case of row 1 (starting at L1) it would first use L1 then M1,N1,O1,P1,Q1 and so on across the sheet.

(I'M HAVING TROUBLE DOING A COPY AND PASTE OF MY SPREADSHEET SO I'LL PUT THE COLUMN NUMBER AT THE TOP)

A1                                   J  K    L   M   
4                                   ROW 1   1-5 1-7
                                    ROW 2       
                                    ROW 3       
                                    ROW 4       
                                    ROW 5       
                                    ROW 6       
                                    ROW 7       
                                    ROW 8       
                                    ROW 9       
                                    ROW 10      
                                    ROW 11      
                                    ROW 12      


5       3       4       2       12              
4       9       6       1       13              
9       7       5       10      14              
6       6       5       11      15              
7       7       7       7       16              
5       5       5       5       17              
4       4       4   1-5 4       18              
1       1       1       1       19              
6       6       6       6       20              
1       5       5       5   1-7 4               
10      5       5       5       5               
7       7       7       7       7               
6       6       6       6       6               
5       5       5       5       5               
5       11      22      33      14              
8       18      17      12      15          

The end

Thanks in advance for any help you can provide.

Russ

Answer 1

This should do it:

Sub do_it()

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

    Set sht = ActiveSheet

    n = sht.Range("A1")

    For Each cell In sht.Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30").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)
            'make sure not to add before col L
            If rngDest.Column < 12 Then Set rngDest = sht.Cells(num, 12)

            cell.Offset(0, 1).Copy rngDest
            Exit For

        End If
    Next

End Sub

Answer 2

you could exploit Worksheet_Change() event and Dictionary object

place this code in your worksheet code pane

Option Explicit

Dim dict As Object

Sub FillDict()
    Set dict = CreateObject("Scripting.Dictionary") 'set a dictionary object

    Dim cell As Range
    For Each cell In Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30").Offset(, 1).SpecialCells(xlCellTypeConstants) ' loop through relevant range 1-column right offset not empty cells
        dict(cell.Offset(, -1).Value) = cell.Value ' add dictionary itme with current cell one column left offset value as key and current cell value as item
    Next
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$A$1" Then Exit Sub 'do nothing if changed cell is not "A1"

    If dict Is Nothing Then FillDict ' fill dictionary if not already set

    If dict.Exists(Target.Value) Then 'if current cell A1 value is in dictionary keys
        Dim rowIndex As Long
        rowIndex = CLng(Trim(Split(dict(Target.Value), "-")(0))) 'get row index from item associated to found key
        Application.EnableEvents = False 'disable events handling to prevent subsequent sheet cells writing to call this sub again
        cells(rowIndex, WorksheetFunction.Max(cells(rowIndex, Columns.Count).End(xlToLeft).Offset(0, 1).Column, 12)).Value = dict(Target.Value)
        Application.EnableEvents = True 'set events handling back
    End If
End Sub

this way you'll have your code read all range cells only once and store relevant results in a dictionary to query each time you change A1 cell content