Değişkene döngü atama

[turkuaz81]

Merhabalar,

Alttaki koddaki işlemlerin "A1500" e kadar devam etmesine çalışıyorum. A2 ye değişken atayıp +1 devam ettirmeye çalıştım olmadı.
Özet olarak; sheet1 den a2/a3/a4... den kopyalayıp, sheet2 ye yapıştırıp sekmeyi kopyalayacak. Nasıl yapabilirim? Teşekkürler.

Sub Makro1()
    Sheets("sheet1").Select
    partno = Range("A2")
    partno ".Select"
    Selection.Copy
    Sheets("sheet2").Select
    Range("F11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("sheet2").Select
    Application.CutCopyMode = False
    Sheets("sheet2").Copy Before:=Sheets(1)
        
End Sub

 

[Ömer]

Merhaba,

Yapmak istediğinizi anlayamadım.
Kopyalama işlemini tek seferde yapabilirsiniz.

Sheets("Sheet1").Range("A2:A1500").Copy
Sheets("Sheet2").Range("F11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

Sheet1 A2:A1500 aralığını Sheet2 F11 den başlayarak kopyalar.

.

 

[turkuaz81]

İlginiz için teşekkürler.
Şöyle anlatayım;
sheet1 de A2-A1500 arasında değerler var. Bu diğerleri sırasıyla , sheet2 de F11 hücresine yapıştırıp , sekmeyi kopyalayıp farklı kaydedeceğim. Yani işlem bittiğinde 1500 ayrı sekme olacak.

 

[Ömer]

Bu şekilde deneyin.

Sub Sayfa_Olustur()

    Dim S1 As Worksheet, S2 As Worksheet, i As Long

    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
    
    For i = 2 To 1500
        If S1.Cells(i, "A") <> "" Then
            S1.Cells(i, "A").Copy
            S2.Range("F11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
            S2.Copy Before:=Sheets(1)
        End If
    Next i
    
    S1.Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
            
End Sub

.

 

[turkuaz81]

Ömer Hocam, eline sağlık süper oldu. İnternette sorun vardı, geç teşekkür edebildim.


Her sekmeyi tanımlı (F11) hücredeki veri ile otomatik adlandırmak için alttaki kodla tamamladım güzel oldu.

Sub sekme_ad_degistirme()
Dim ts(), kaplan
Sheets(1).Select
ReDim ts(Sheets.Count - 1)
For kaplan = 0 To Sheets.Count - 1
ts(kaplan) = Sheets(kaplan + 1).Name
Sheets(ts(kaplan)).Select
Sheets(ts(kaplan)).Name = Range("F11")
Next kaplan
End Sub

 

[Ömer]

Bu işlemi verdiğim koda ilaveylede yapabilirsiniz.

#4 numaralı mesajda verdiğim kodlardaki;

S2.Copy Before:=Sheets(1)

satırından sonra aşağıdaki satırı ilave edin.

ActiveSheet.Name = S2.Range("F11")

.