VBA Macro - Loop and get value then ovewrite the desired cell

user_9774078 0
Viewed 154

I created a loop that will get the value of one cell to another cell under the same sheet. The expected result should be this, if the loop runs it will get the 1st value then run my created procedure next overwrite the same cell get the 2nd value then execute again my created procedure then get 3rd value .. overwrite the cell ..exec proc and so on ... But my codes only get the last value of the selection.

enter image description here

    Public Sub SpecNum()

    Dim lrow As Long

    Range("A2").Select
    lrow = Selection.End(xlDown).Row

        For x = 2 To lrow

            Range("C2").Value2 = Cells(x, 1).Value2

        Next x
            Number

    End Sub


    Public Sub Number()

    Dim SpecNum, pref, lastCell As String
    Dim lrow As Long

    SpecNum = Range("C2").Value2


        For x = 2 To 6

            Worksheets("Sheet3").Select
            pref = Cells(x, "E").Value2
            Cells(x, "C").Value2 = SpecNum & pref
            Range("C2", Range("C2").End(xlToRight).End(xlDown)).Copy

        Next x

            Worksheets("Sheet1").Select
            Range("A250").Select
            Selection.End(xlUp).Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste

    End Sub

output when moving the number inside the loop.. it doubled/tripled the values enter image description here

expected result:

enter image description here

vba excel
2 Answers

modified your loop structures. May try

Public Sub SpecNum()

    Dim lrow As Long

    Range("A2").Select
    lrow = Selection.End(xlDown).Row

        For X = 2 To lrow
        Range("C2").Value2 = Cells(X, 1).Value2
        Number
        Next X


    End Sub

    Public Sub Number()

    Dim SpecNum, pref, lastCell As String
    Dim lrow As Long

    SpecNum = Range("C2").Value2


        For X = 2 To 6

            Worksheets("Sheet3").Select
            pref = Cells(X, "E").Value2
            Cells(X, "C").Value2 = SpecNum & pref
            'Range("C2", Range("C2").End(xlToRight).End(xlDown)).Copy
            Range("C" & X, Range("C" & X).End(xlToRight)).Copy

            Worksheets("Sheet1").Select
            Range("A15").End(xlDown).End(xlDown).End(xlUp).Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
    Next X

    End Sub

Or may please opt for simplified solution in single procedure

    Public Sub SpecNum2()

    Dim lrow As Long
    Worksheets("Sheet1").Range("A2").Select
    lrow = Selection.End(xlDown).Row
    TrgRw = 15

        For X = 2 To lrow
        NumX = Worksheets("Sheet1").Cells(X, 1).Value2


            For Y = 2 To 6
            TrgRw = TrgRw + 1
            Worksheets("Sheet3").Select
            pref = Cells(Y, "E").Value2
            Cells(Y, "C").Value2 = NumX & pref
            'Range("C2", Range("C2").End(xlToRight).End(xlDown)).Copy
            Range("C" & Y, Range("C" & Y).End(xlToRight)).Copy

            Worksheets("Sheet1").Select
            Range("A" & TrgRw).Select
            ActiveSheet.Paste
            Next Y
       Next X
End Sub

Hope It will work

user_104057780

I refactored your code a bit. First of all - you should learn how to avoid using Selections (How to avoid using Select in Excel VBA). Code without Selections is more flexible and less confusing.

Hope it works as you wanted:

Option Explicit
Public Sub SpecNum()
Dim lrow    As Long
Dim x       As Long
Dim wb      As Workbook
Dim ws      As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet3")

lrow = ws.Range("A2").End(xlDown).row

For x = 2 To lrow
    ws.Range("C2").Value2 = ws.Cells(x, 1).Value2
    Number
Next x
End Sub

Public Sub Number()
Dim SpecNum As String
Dim pref    As String
Dim lrow    As Long
Dim x       As Long
Dim wb      As Workbook
Dim ws3     As Worksheet
Dim ws1     As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws3 = wb.Worksheets("Sheet3")

SpecNum = ws3.Range("C2").Value2

For x = 2 To 6
    pref = ws3.Cells(x, "E").Value2
    ws3.Cells(x, "C").Value2 = SpecNum & pref
Next x
ws3.Range("C2", ws3.Range("C2").End(xlToRight).End(xlDown)).Copy

ws1.Range("A250").End(xlUp).Offset(1, 0).PasteSpecial
End Sub
user_75766460
Related