VBA Macro - цикл и получить значение, а затем переписать нужную ячейку

Question

Я создал цикл, который будет получать значение одной ячейки в другую ячейку под тем же листом. Ожидаемый результат должен быть следующим: если цикл запустится, он получит 1-е значение и запустит мою созданную процедуру затем перезаписываем ту же ячейку, получаем 2-е значение, затем снова выполняем созданную мной процедуру, затем получаем 3-е значение .. перезаписываем ячейку ..exec proc и так далее ... Но мои коды получают только последнее значение выбора.

    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

вывод при перемещении числа внутри цикла .. он удвоил / утроил значения

ожидаемый результат:

Answer 1

Я немного изменил ваш код. Прежде всего - вы должны научиться избегать использования выбора ( Как избежать использования Select в Excel VBA ). Код без выбора более гибкий и менее запутанный.

Надеюсь, это работает так, как вы хотели:

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

Answer 2

изменил ваши структуры цикла. Может попробовать

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

Или, пожалуйста, выберите упрощенное решение за одну процедуру

    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

Надеюсь, что это будет работать