Excel Hücre sayısal değeri kadar başka hücreye değer kopyalama

[Macaroglu]

Merhabalar,

Linkdeki dosyada sayfa1 içerisindeki tabloda kod ve adet sütunları mevcut.
sayfa2 içerisinde de 4x2 boş bir tablo var. ( 4 Sütun x 2 Satır )

Benim yapmak istediğim sayfa1 'deki kodun adeti kadar, sayfa2 'deki tabloya kodun kendisini yazdırmak.

Sanırım şu tarz bir algoritma gerekiyor,
eğer adet > 0 ise sayfa2 'ye git A1 hücresine kodu yapıştır, adeti 1 kere düşür;
eğer hala adet > 0 ise sayfa2 'ye git B1 hücresine kodu yapıştır, adeti 1 kere düşür;
eğer hala adet > 0 ise sayfa2 'ye git A2 hücresine kodu yapıştır, adeti 1 kere düşür;

eğer adet <=0 ise adet sütununda bir alt hücreye git, hiç bir yere bir şey yapıştırma

Bunu Excel'de nasıl yapabilirim?

http://s6.dosya.tc/server11/zmsrwd/Deneme.xlsx.html

 

[Ömer]

Merhaba,

8*6 tablo demişsiniz. Sayfa2 deki tablonun sütun sayısı maksimum 2 mi olacak 6 mı olacak?

 

[Macaroglu]

Merhaba,

8*6 tablo demişsiniz. Sayfa2 deki tablonun sütun sayısı maksimum 2 mi olacak 6 mı olacak?

Afedersiniz, düzelttim. 4 x 2 tablo.

 

[Ömer]

Tablodaki satır sayısına sınır koymadım. Sütun sayısını 2 yaptım.

Sub Duzenle()

    Dim S2 As Worksheet, i As Long, j As Long, sat As Long, sut As Byte
    
    Set S2 = Sheets("Sayfa2")

    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Range("A:B").ClearContents
    
    sat = 1: sut = 1
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "B") > 0 Then
            For j = 1 To Cells(i, "B")
                If sut Mod 3 = 0 Then sut = 1: sat = sat + 1
                S2.Cells(sat, sut) = Cells(i, "A")
                sut = sut + 1
            Next j
        End If
    Next i
    S2.Select
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[Macaroglu]

Çok teşekkür ederim. Mükemmel oldu. Satır kısmına sınır koymamanız da çok işime yaradı.
Tek bir eksiğim kaldı.
sayfa2 de yapıştırmanın yapıldığı satırların alt başlıkları mevcut bende.
yani yapıştırmanın yapılacağı satırların 1,4,7,10,13,16,19 olarak devam etmesi gerekiyor. Bunu nasıl sağlayabilirim

 

[Macaroglu]

Tamamdır. Onu da satır = satır + 3 yaparak çözdüm

Teşekkür ederim

 

[Macaroglu]

Kendi bulduğum çözümde bir problemle karşılaştım.

Yeni bir dosya linki koydum aşağıya.

Burada sayfa2 deki sarı ile belirttiğim alanlar siliniyor.

Bu alanların içeriğinin aynı şekilde kalmasını nasıl sağlayabilirim?

http://s5.dosya.tc/server5/8vydpy/Deneme.xlsx.html

 

[Ömer]

S2.Range("A:B").ClearContents

Alanı önce sildiğim için, sabitlerde siliniyor.

Sarı alandaki değerler her zaman aynı mı değişebiliyor mu?

Silme işlemini ona göre yapacağım.

Duruma göre silebilir, yada tamamen silip yenide yazdırabiliriz.

.

 

[Macaroglu]

S2.Range("A:B").ClearContents

Alanı önce sildiğim için, sabitlerde siliniyor.

Sarı alandaki değerler her zaman aynı mı değişebiliyor mu?

Silme işlemini ona göre yapacağım.

Duruma göre silebilir, yada tamamen silip yenide yazdırabiliriz.

.

Değerler sürekli sabit.

 

[Ömer]

Bu şekilde deneyin.

Sub Duzenle()

    Dim S2 As Worksheet, i As Long, j As Long, sat As Long, sut As Byte
    
    Set S2 = Sheets("Sayfa2")

    Application.ScreenUpdating = False
    S2.Range("A:B").Clear
    
    With Sheets("Sayfa1")
        sat = 1: sut = 1
        For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
            If .Cells(i, "B") > 0 Then
                For j = 1 To .Cells(i, "B")
                    If sut Mod 3 = 0 Then
                        S2.Cells(sat + 1, sut - 2).Resize(2, 2).Interior.ColorIndex = 6
                        S2.Cells(sat + 1, sut - 2).Resize(1, 2) = "Ürün Adı"
                        S2.Cells(sat + 2, sut - 2).Resize(1, 2) = "10 adet"
                        sut = 1: sat = sat + 3
                    End If
                    S2.Cells(sat, sut) = .Cells(i, "A")
                    sut = sut + 1
                Next j
            End If
        Next i
    End With
    S2.Select

    With Range("A1:B" & sat)
        .Borders.LineStyle = 1
        .Font.Name = "Calibri"
        .Font.Size = 14
        .HorizontalAlignment = xlCenter
        .EntireColumn.AutoFit
    End With
    
    Application.ScreenUpdating = True
    
End Sub

.