• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Verilen Sayı Kadar Kopyalama

S

serhatdemirer

Katılım
6 Kasım 2015
Mesajlar
4
Excel Vers. ve Dili
Office 2013
Merhabalar,

Hepinize iyi akşamlar diliyorum. Şimdi Sheet1 sayfamın A2 hücresinde bir isim var. B2 hücresinde ise bu ismin kaç kez tekrar edilmesi gerektiği var. Ben istiyorum ki, A2 hücresindeki değer Sheet2'nin D2 hücresinden aşağı doğru B2 hücresindeki kadar kopyalansın. Yani ben B2'ye 36 yazarsam Sheet2'de D2'den itibaren 36 kere kopyalasın. Sonrasında bu değer bitince diğer değerin bittiği yerden başlamak kaydıyla, A3 hücresine yazdığım değer B3 hücresindeki kadar kopyalasın.
Umarım anlatabilmişimdir. Bu durumda benim işime yarayacak bir şey var mı?
 
Merhaba,
Aşağıdaki kodu deneyiniz.
Kod: 
Sub KOD()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Set son = s2.Range("D2")
For a = 2 To s1.Range("A65500").End(3).Row
    If IsNumeric(s1.Cells(a, "B")) Then
        Set sson = son.Offset(s1.Cells(a, "B") - 1)
        Range(son, sson) = s1.Cells(a, "A")
        Set son = sson.Offset(1)
    End If
Next
End Sub
 
Buyurun.:cool:
Kod: 
Sub kopyala59()
Dim sh As Worksheet, sonsat As Long, i As Long, j As Long
Dim sat As Long
Set sh = Sheets("Sheet2")
Sheets("Sheet1").Select
sh.Range("D2:D" & Rows.Count).Clear
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
sat = 2
For i = 2 To sonsat
    If IsNumeric(Cells(i, "B").Value) Then
        For j = 1 To Cells(i, "B").Value
            sh.Cells(sat, "D").Value = Cells(i, "A").Value
            sat = sat + 1
        Next j
    End If
Next i
sh.Select
Set sh = Nothing
End Sub
 
MERHABA BENDE BUNA BENZER BİR SORUN YAŞIYORUM .ANCAK BEN SADECE A2 HÜCRESİNDEKİ İSİMLERİ DEĞİLDE A2 DAN H2 YE KADAR OLAN SATIRLARI KOPYALAMAK İSTİYORUM YARDIMCI OLABİRMİSİNİZ
 
sametseyman' Alıntı:
MERHABA BENDE BUNA BENZER BİR SORUN YAŞIYORUM .ANCAK BEN SADECE A2 HÜCRESİNDEKİ İSİMLERİ DEĞİLDE A2 DAN H2 YE KADAR OLAN SATIRLARI KOPYALAMAK İSTİYORUM YARDIMCI OLABİRMİSİNİZ
Genişletmek için tıkla ...

Kaç satır kopyalanacağını kod yazacak kişiye mi bırakıyorsunuz?

Kodu kendinize göre uyarlayınız.

Kod: 
Sub Makro1()

Dim SatirSayisi As Integer

SatirSayisi = 10

    Range("A2:H" & 2 + SatirSayisi).FillDown
    
End Sub
 
Necdet' Alıntı:
Kaç satır kopyalanacağını kod yazacak kişiye mi bırakıyorsunuz?

Kodu kendinize göre uyarlayınız.

Kod: 
Sub Makro1()

Dim SatirSayisi As Integer

SatirSayisi = 10

    Range("A2:H" & 2 + SatirSayisi).FillDown
  
End Sub
Genişletmek için tıkla ...


necdet bey ilk defa bugun bu konu ie uğraşıyorum mallesef bilgi 0 teşekkür ederim.. bu verdiklerinizi eklemeyi bilemedim ilk kodlara siz eklermisiniz rica etsem yaparmısınız
 
Merhaba,

Alt+F11 ile vba editörünü açmış olursunuz
Insert+Module ile yeni bir modül eklemiş olursunuz
onun sağ tarafındaki boşluk ki modüle yazılan kodların olduğu yerdir, yukarıda verdiğim kodları oraya yapıştırın
açılan ekranı kapatmadan menüden Run ile kodları çalıştırabilirsiniz.
Yada
Excelden geliştirici sekmesinden makrolar
oradan istediğiniz makroyu (ki birden fazla olabilir) çalıştırabilirsiniz.
 
Merhaba,

Özelden açıkladığınız şekilde kodları düzenledim, örnek doyayı da buraya ekliyorum.
Kodların doğru çalışıp çalışmadığını kontrol için sonucu J sütunundan itibaren yazdırdım.
Kodların doğru çalıştığına emin olduğunuzda ana veri üzerine yazdırılabilinir.

Kod: 
Public Sub SatirCogalt()

Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim a   As Integer
Dim adt As Integer
Dim top As Long
Dim arr1 As Variant
Dim arr2 As Variant

Application.ScreenUpdating = False

i = Cells(Rows.Count, "A").End(3).Row

arr1 = Range("A1").CurrentRegion.Value
top = Evaluate("=SUM(H2:H" & i & ")") + Evaluate("=COUNTBLANK(H2:H" & i & ")") + 1
arr2 = Range("A1:H" & top + 1).Value

j = 1
For i = 2 To UBound(arr1, 1)
    If Not arr1(i, UBound(arr1, 2)) = "" Then
        adt = arr1(i, UBound(arr1, 2))
    Else
        adt = 1
    End If
    For a = 1 To adt
        j = j + 1
        For k = 1 To UBound(arr1, 2)
            arr2(j, k) = arr1(i, k)
        Next k
    Next a
Next i

With Range("J1")
    .ClearContents
    .Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End With

MsgBox "İşlem Tamamdır...."

Application.ScreenUpdating = True

End Sub
 

Ekli dosyalar

Son düzenleme:
Merhaba,
9. mesajdaki kodları yeniden düzenledim.
Sadece 1 kere yazılması gereken satırlar için 1 değerini yazmanıza gerek yok.
Birden fazla tekrarlanacak olan değerleri yazmanız yeterli.
 
Merhaba,
Israrla Özel mesajdan isteğinizi dile getiriyorsunuz, ben de buraya aktarıyorum :)

Özel İsteğiniz :
NECDET USTAM ,

SENDEN BİR RİCAM DAHA OLUCAK .

S.NO KISMANDA KENDİM YAPMAYA ÇALIŞTIM AMA TAM OLMADI B2' YE 1 B3'E 2 YAZDIRIP ONDAN SONRA KAÇTANE DOLU HÜCRE VARSA 3 4 5 DİYE SON HÜCREYE KADAR SIRALAMASINI İSTİYORUM.

BİRDE SAYI KISMI VARYA USTAM ONDADA 1 / 13 YAZIYOR YA ODA SIRAYLA 1 YANINDAKİ SAYI KAÇSA AŞAYA KADAR ÖYLE KOPYALASA OLURMU

ÇOK ZAHMET VERDİM SİZEDE VAKTİNİZ YOKSA YAPMAZSANIZDA ELİNİZE SAĞLIK BÜYÜK İŞİ ÇÖZMÜŞ OLDUNUZ
Genişletmek için tıkla ...

Veri Girişi Formatını resimde görüldüğü gibi yapın.

AÇIKLAMA

S.NO

GEN

YÜK

P.NO

CARİ UNVAN

MÜŞTERİ

SAYI

ADET

4+12+4 Çift Cam

725

690

1130

1

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

727

430

830

2

FİDAN YAPI

AHMET UZUN



3

4+12+4 Çift Cam

729

545

1170

3

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

731

455

545

4

FİDAN YAPI

AHMET UZUN



4

4+12+4 Çift Cam

733

455

565

5

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

735

475

1075

6

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

737

565

1160

7

FİDAN YAPI

AHMET UZUN



2

4+12+4 Çift Cam

739

500

1070

8

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

741

565

380

9

FİDAN YAPI

AHMET UZUN



2

4+12+4 Çift Cam

743

585

380

10

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

745

250

430

11

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

747

250

1200

12

FİDAN YAPI

AHMET UZUN





4+10.5+4 Buzlu Çift cam

749

645

995

13

FİDAN YAPI

AHMET UZUN



2

4+10.5+4 Buzlu Çift cam

751

680

995

14

FİDAN YAPI

AHMET UZUN



2

4+16+4 Çift Cam

753

609

945

1

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

755

509

845

2

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

757

354

860

3

CAN YAPI

ALİNİN KOMŞUSU



5

4+16+4 Çift Cam

759

454

960

4

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

761

509

860

5

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

763

609

960

6

CAN YAPI

ALİNİN KOMŞUSU




Yani çoğaltmak istediğinz satır sayısı I sütununda olsun.



Aşağıdaki kodları deneyiniz.
Kod: 
Public Sub SatirCogalt()

Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim a   As Integer
Dim adt As Integer
Dim top As Long
Dim arr1 As Variant
Dim arr2 As Variant

Application.ScreenUpdating = False

i = Sayfa1.Cells(Rows.Count, "A").End(3).Row

Sayfa1.Range("A2:I" & i).Sort key1:=[G1], Key2:=[F1]

arr1 = Sayfa1.Range("A1").CurrentRegion.Value
top = Evaluate("=SUM(I2:I" & i & ")") + Evaluate("=COUNTBLANK(I2:I" & i & ")") + 1
arr2 = Sayfa1.Range("A1:I" & top + 1).Value

j = 1
For i = 2 To UBound(arr1, 1)
    If Not arr1(i, UBound(arr1, 2)) = "" Then
        adt = arr1(i, UBound(arr1, 2))
    Else
        adt = 1
    End If
    For a = 1 To adt
        j = j + 1
        For k = 1 To UBound(arr1, 2)
            arr2(j, k) = arr1(i, k)
        Next k
    Next a
Next i

With Sayfa1.Range("A1").CurrentRegion
    .ClearContents
    .Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End With

i = Sayfa1.Cells(Rows.Count, "A").End(3).Row
Sayfa1.Range("B2") = 1
Sayfa1.Range("B2:B" & i).DataSeries
With Sayfa1.Range("H2")
    .FormulaR1C1 = "=COUNTIF(R2C7:R" & i & "C7,RC[-1])"
    .AutoFill Destination:=Range("H2:H" & i)
End With

Erase arr2
arr2 = Range("A1:I" & i).Value

For i = LBound(arr2, 1) + 1 To UBound(arr2, 1)
    If Not arr2(i, 7) = deg Then
        deg = arr2(i, 7)
        adt = 1
    Else
        adt = adt + 1
    End If
    arr2(i, 8) = adt & Chr(160) & "/" & Chr(160) & arr2(i, 8)
Next i
With Sayfa1.Range("A1").CurrentRegion
    .Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End With

Application.ScreenUpdating = True

MsgBox "İşlem Tamamdır...."

End Sub
 

Ekli dosyalar

Son düzenleme:
Necdet' Alıntı:
Merhaba,
Israrla Özel mesajdan isteğinizi dile getiriyorsunuz, ben de buraya aktarıyorum :)

Özel İsteğiniz :

Veri Girişi Formatını resimde görüldüğü gibi yapın.

AÇIKLAMA

S.NO

GEN

YÜK

P.NO

CARİ UNVAN

MÜŞTERİ

SAYI

ADET

4+12+4 Çift Cam

725

690

1130

1

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

727

430

830

2

FİDAN YAPI

AHMET UZUN



3

4+12+4 Çift Cam

729

545

1170

3

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

731

455

545

4

FİDAN YAPI

AHMET UZUN



4

4+12+4 Çift Cam

733

455

565

5

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

735

475

1075

6

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

737

565

1160

7

FİDAN YAPI

AHMET UZUN



2

4+12+4 Çift Cam

739

500

1070

8

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

741

565

380

9

FİDAN YAPI

AHMET UZUN



2

4+12+4 Çift Cam

743

585

380

10

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

745

250

430

11

FİDAN YAPI

AHMET UZUN





4+12+4 Çift Cam

747

250

1200

12

FİDAN YAPI

AHMET UZUN





4+10.5+4 Buzlu Çift cam

749

645

995

13

FİDAN YAPI

AHMET UZUN



2

4+10.5+4 Buzlu Çift cam

751

680

995

14

FİDAN YAPI

AHMET UZUN



2

4+16+4 Çift Cam

753

609

945

1

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

755

509

845

2

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

757

354

860

3

CAN YAPI

ALİNİN KOMŞUSU



5

4+16+4 Çift Cam

759

454

960

4

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

761

509

860

5

CAN YAPI

ALİNİN KOMŞUSU





4+16+4 Çift Cam

763

609

960

6

CAN YAPI

ALİNİN KOMŞUSU




Yani çoğaltmak istediğinz satır sayısı I sütununda olsun.




Aşağıdaki kodları deneyiniz.
Kod: 
Public Sub SatirCogalt()

Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim a   As Integer
Dim adt As Integer
Dim top As Long
Dim arr1 As Variant
Dim arr2 As Variant

Application.ScreenUpdating = False

i = Sayfa1.Cells(Rows.Count, "A").End(3).Row

Sayfa1.Range("A2:I" & i).Sort key1:=[G1], Key2:=[F1]

arr1 = Sayfa1.Range("A1").CurrentRegion.Value
top = Evaluate("=SUM(I2:I" & i & ")") + Evaluate("=COUNTBLANK(I2:I" & i & ")") + 1
arr2 = Sayfa1.Range("A1:I" & top + 1).Value

j = 1
For i = 2 To UBound(arr1, 1)
    If Not arr1(i, UBound(arr1, 2)) = "" Then
        adt = arr1(i, UBound(arr1, 2))
    Else
        adt = 1
    End If
    For a = 1 To adt
        j = j + 1
        For k = 1 To UBound(arr1, 2)
            arr2(j, k) = arr1(i, k)
        Next k
    Next a
Next i

With Sayfa1.Range("A1").CurrentRegion
    .ClearContents
    .Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End With

i = Sayfa1.Cells(Rows.Count, "A").End(3).Row
Sayfa1.Range("B2") = 1
Sayfa1.Range("B2:B" & i).DataSeries
With Sayfa1.Range("H2")
    .FormulaR1C1 = "=COUNTIF(R2C7:R" & i & "C7,RC[-1])"
    .AutoFill Destination:=Range("H2:H" & i)
End With

Erase arr2
arr2 = Range("A1:I" & i).Value

For i = LBound(arr2, 1) + 1 To UBound(arr2, 1)
    If Not arr2(i, 7) = deg Then
        deg = arr2(i, 7)
        adt = 1
    Else
        adt = adt + 1
    End If
    arr2(i, 8) = adt & Chr(160) & "/" & Chr(160) & arr2(i, 8)
Next i
With Sayfa1.Range("A1").CurrentRegion
    .Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End With

Application.ScreenUpdating = True

MsgBox "İşlem Tamamdır...."

End Sub
Genişletmek için tıkla ...

NECDET USTAM ELİNE KOLUNA SAĞLIK ŞUAN TAM ANLAMIYLA İSTEDİĞİM ŞEKİLDE SON NOKTA OLDU DAHASI OLAMAZDI EYVALLAH GÜZEL İNSANSIN..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst