Çözüldü HÜCREDEKİ BİLGİYİ YAN HÜCREDEKİ SAYI KADAR, FARKLI BİR HÜCREDE ALT ALTA ÇOĞALTMA

[DAYWALKER2018]

MAKRO KONUSUNDA ÇOK DENEYİMİM YOK. SİZDEN RİCAM AŞAĞIDAKİ KONU HAKKINDA YARDIMCI OLMANIZ. BUNA İHTİYAÇ DUYMAMIN SEBEBİ ALINAN SİPARİŞLERİN KUTULARINA BİLGİ BARKODU BASMAM GEREKİYOR VE AYNI ÜRÜN 1 DEN FAZLA KUTUYA GİRİYOR. KUTU ADEDİ KADAR BARKOD BASMAM GEREKİYOR.

BASİTÇE AŞAĞIDA İSTEDİĞİME ÖRNEK YAZDIM;
"A" SÜTÜNUNDA GİRMİŞ OLDUĞUM ÜRÜN BİLGİSİNİ "E" SÜTÜNUNDA "B"SÜTÜNÜN ADEDİ KADAR ÇOĞALTACAK BİR MAKROYA İHTİYACIM VAR ÖRNEK OLARAK "ÜTÜ" ÜRÜNÜN YANINDA "5" YAZIYOR BUNU AYRI BİR SÜTÜNDA ALT ALTA "5" KERE "ÜTÜ" YAZMASINI İSTİYORUM. SONRASINDA DA "ÜTÜ'NÜN" NIN ALTINDAKİ DEĞER DE AYNISINI YAPMASINI İSTİYORUM YAZILAN DEĞERLER BİTENE KADAR. ÖRNEK EKTE MEVCUT

ŞİMDİDEN GÖSTERMİŞ OLDUĞUNUZ İLGİYE TEŞEKKÜR EDERİM,

İYİ ÇALIŞMALAR,

 

[Ömer]

Merhaba,

Ek boştu,anladığım kadarıyla yazdım.
Bu şekilde deneyin.

Sub Cogalt()
    
    Dim i As Long, sat As Long
    
    Application.ScreenUpdating = False
    Range("E2:E" & Rows.Count).ClearContents
    
    sat = 2
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "B") > 0 Then
            Cells(i, "A").Copy Cells(sat, "E").Resize(Cells(i, "B"), 1)
            sat = Cells(Rows.Count, "E").End(xlUp).Row + 1
        End If
    Next i
        
End Sub

 

[DAYWALKER2018]

Merhaba,

Ek boştu,anladığım kadarıyla yazdım.
Bu şekilde deneyin.

Sub Cogalt()
   
    Dim i As Long, sat As Long
   
    Application.ScreenUpdating = False
    Range("E2:E" & Rows.Count).ClearContents
   
    sat = 2
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "B") > 0 Then
            Cells(i, "A").Copy Cells(sat, "E").Resize(Cells(i, "B"), 1)
            sat = Cells(Rows.Count, "E").End(xlUp).Row + 1
        End If
    Next i
       
End Sub

özürdilerim dosyayı kaydetmemişim öylece yükleyince boş yüklenmiş. Şimdi yükledim.

 

[DAYWALKER2018]

özürdilerim dosyayı kaydetmemişim öylece yükleyince boş yüklenmiş. Şimdi yükledim.

denedim aynen olmuş elinize sağlık . Bu konunun devamı ile ilgili olarak orjinal yaptığım dosyada deneyeceğim inşallah orda olur çünkü bilgiler listbox'tan geliyor. Başka bir kod bulup denemiştim ama listboxtaki yazan veriyi çekmeye çalıştığımda hata veriyordu

 

[Necdet]

Merhaba,

Ömer Bey'in kodlarını da inceleyin.

Aşağıdaki kodları deneyiniz.

Sub Cogalt()

    Dim i   As Long, _
        j   As Long, _
        k   As Long
    
    Range("D:E").Clear
    j = 1
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        j = j + 1
        k = j + Cells(i, "B") - 1
        Range("D" & j & ":D" & k) = Cells(i, "A")
        Range("E" & j) = Cells(i, "B")
        With Range("E" & j & ":E" & k)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        j = k
    Next i
    
End Sub

 

[DAYWALKER2018]

denedim aynen olmuş elinize sağlık . Bu konunun devamı ile ilgili olarak orjinal yaptığım dosyada deneyeceğim inşallah orda olur çünkü bilgiler listbox'tan geliyor. Başka bir kod bulup denemiştim ama listboxtaki yazan veriyi çekmeye çalıştığımda hata veriyordu

Ekte kullanacağım dosya mevcut. Sizin vermiş olduğunuz kodları " sipariş formu " çalışma sayfasında kullandım. Fakat T ve U sütünuna değerleri getirmiyor. Sanırsam getirmek istediği yerde formül olduğu için böyle yapıyor. Bunun bir çaresi varmıdır ?

 

[DAYWALKER2018]

Merhaba,

Ek boştu,anladığım kadarıyla yazdım.
Bu şekilde deneyin.

Sub Cogalt()
   
    Dim i As Long, sat As Long
   
    Application.ScreenUpdating = False
    Range("E2:E" & Rows.Count).ClearContents
   
    sat = 2
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "B") > 0 Then
            Cells(i, "A").Copy Cells(sat, "E").Resize(Cells(i, "B"), 1)
            sat = Cells(Rows.Count, "E").End(xlUp).Row + 1
        End If
    Next i
       
End Sub

Ekte kullanacağım dosya mevcut. Sizin vermiş olduğunuz kodları " sipariş formu " çalışma sayfasında kullandım. Fakat T ve U sütünuna değerleri getirmiyor. Sanırsam getirmek istediği yerde formül olduğu için böyle yapıyor. Bunun bir çaresi varmıdır ?

 

[Ömer]

Cells(i, "I").Copy Cells(sat, "T").Resize(Cells(i, "J"), 1)

yerine;

Cells(i, "I").Copy
Cells(sat, "T").Resize(Cells(i, "J"), 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

yazarsınız. Bu şekilde değerleri yapıştırır. Koddaki diğer alanlar içinde aynı değişikliği yaparsınız.

.

 

[DAYWALKER2018]

Cells(i, "I").Copy Cells(sat, "T").Resize(Cells(i, "J"), 1)

yerine;

Cells(i, "I").Copy
Cells(sat, "T").Resize(Cells(i, "J"), 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone

yazarsınız. Bu şekilde değerleri yapıştırır. Koddaki diğer alanlar içinde aynı değişikliği yaparsınız.

.

işlem tamam ellerinize sağlık .
Bunun dışında birkaç sorum daha olacak buna cevap alma şansım var ise sevinirim veya beni forumda yapmam gereken ne ise yönlendirebilirseniz sevinirim ( malum yeni forum kullanıcısıyım, yeni derken genel anlamda "forum" ilk defa kullanıyorum tecrübem yok , yavaş yavaş oluyor )

1- ) Sipariş dosyasında listbox içindeki yazıları seçmeye kalktığımda yazılar çok küçük bunları seçildiğinde büyük görünmesini sağlayabilirmyim. ( sayfa görünürlüğünü büyütmeden )
2- ) Sipariş dosyasında makro ile oluşturduğum barkod bilgilerini worde gönderip çıktı almanın yolunu buldum. Fakat direk excelden istediğim büyüklükleri tanımlayıp ( örnek 10x15 boyut ) o verilerin çıktısını alma şansım varmıdır ? (makro veya makrosuz ) örnek barkod çıktısı ekte mevcut. Bu yaptığım dosyayı ben kullanmayacağım ama kullanacak kişi/ler bilgili değil benim kadar. Bende basit birşey yapmaya çalışıyorum. Tek bir dosyada işi bitirebilirsem süper olacak.
3-) Birde ileriki safham ürün modelinin barkod ( code39 ) ile yazdırıp hazırlanan siparişin barkod etiketlerini okutup sipariş formu ile tutarlığını kontrol ettireceğim. Bunun hakkında da tavsiyenizi almak isterim.