• DİKKAT

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

Sağada doğru yanyana yazdırma için döngüsel başvuru

Katılım
2 Şubat 2013
Mesajlar
11
Excel Vers. ve Dili
Excel 2007 (türkçe)
Merhaba
Ekteki tablomda U sütununda değer var ise B sütunundaki metinleri (örneğin 3 se, 3 kez; 5 ise 5 kez) AF sütunundan itibaren sağa doğru yazdırmak istiyorum. bu yazdırma işlemi bitince 1 hücre boş bırakarak V sütununda değer var ise yine B sütunundaki metinleri yazdırmaya devam etmesini istiyorum ve bu işlemin AE sütuna kadar devam etmesi gerekiyor. Birden fazla koşul bulunduğu için kodlar konusunda çaresiz kaldım. Yardımınızı rica edebilirmiyim.
 

Ekli dosyalar

Merhaba.

konuyu anlaşılır biçimde yazarsanız size yardım edebilirim.
 
çalışma ekde
program yenile butonunu tıkla...
 

Ekli dosyalar

Merhaba
Yukarıdaki sorumda düşayarama fonkisyonu da işin içine girdi ve benim için içinden çıkılmaz bir hal aldı.Excelde düşeyarama fonksiyonunu da kullanarak ilgili hücredeki değer kadar yansayfada metinleri yazdırmak istiyorum. Bu konuda yardımcı olabilecek bir arkadaş var ise çok sevinirim
Örnek:
W2 de 8 değeri var. A2’deki değeri Plan sayfasında bulsun ve Plan sayfasında E80den başlayarak 8 kez E2 hücre içeriğini yazsın. Eğer X2 boş ise W3 e geçsin;
W3 de 5 değeri var. A3 deki değeri Plan sayfasında bulsun ve Plan sayfasında E9 dan itibaren 5 kez E3 hücre içeriğini yazsın. Eğer X3 boş ise W4 e geçsin… X3 Dolu ise;
X3de 3 değeri var. (E9 dan itibaren 5 hücre dolu olduğu için) 1 boşluk bırakarak yani K9 dan itibaren E4 hücre içeriğini yazsın. Eğer Y3 boş ise W5 e geçsin…. Y3 dolu ise;
Y3 de 5 değeri var. (E9dan itibaren 9 hücre dolu olduğu için) 1 boşluk bırakarak yani O9 dan itibaren E5 hücre içeriğini yazsın. Eğer Z3 boş ise W6 ya geçsin….
W ile AF arasında bir değer olduğu müddetçe bu yan yana yazdırma işlemini diğer sayfada yaptırmak istiyorum
Örnek çalışmam bu mesaj ekindedir.
 

Ekli dosyalar

Merhaba,

Aşağıdaki kodu deneyiniz.

Kod:
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Y As Byte, BUL As Range
    Dim Satir As Long, Sutun As Integer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("PLAN")
    
    S2.Range("E3:" & Cells(Rows.Count, Columns.Count).Address(0, 0)).ClearContents
    Sutun = 5
    
    For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        Set BUL = S2.Range("A:A").Find(S1.Cells(X, 1), , , xlWhole)
        If Not BUL Is Nothing Then
            For Y = 23 To 32
                If S1.Cells(X, Y) <> "" And S1.Cells(X, Y) > 0 Then
                    If Satir < X Then Satir = X
                    If Y > 23 Then
                        Satir = Satir + 1
                        Sutun = Sutun + 1
                    End If
                    S2.Range(S2.Cells(BUL.Row, Sutun), S2.Cells(BUL.Row, Sutun - 1 + Round(S1.Cells(X, Y)))).Value = S1.Cells(Satir, 5)
                    Sutun = Sutun - 1 + Round(S1.Cells(X, Y)) + 1
                End If
            Next
            Sutun = 5
        End If
    Next
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan bey, aradığım kod buydu..Çok işime yaradı. Ellerinize sağlık, sağolun.
 
Geri
Üst