Excel adet kadar yazdırma

[nkeles]

İyi günler arkadaşlar,

Excel de B sutününde kaç adet yazıyorsa A sütunundaki bilgiler C D E F G H ....n sütunlarına yazsın istiyorum. Kısaca kaç adet varsa o adet kadar bir sonraki hücrelere yazdırmak istiyorum.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Sub Yaz()
    
    Dim i As Long, _
        j As Integer
        
    Application.ScreenUpdating = False
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        j = 2 + Cells(i, "B")
        Range(Cells(i, "C"), Cells(i, j)) = Cells(i, "A")
    Next i
    Application.ScreenUpdating = True
    MsgBox "Bitti...."
    
End Sub

 

[nkeles]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Sub Yaz()
    
    Dim i As Long, _
        j As Integer
        
    Application.ScreenUpdating = False
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        j = 2 + Cells(i, "B")
        Range(Cells(i, "C"), Cells(i, j)) = Cells(i, "A")
    Next i
    Application.ScreenUpdating = True
    MsgBox "Bitti...."
    
End Sub

Örnek olarak gönderdiğim dosyaya eklediğimde evet oldu. Ama diğer dosyalarda hata verdi. Asıl olması gereken dosya ekte.

 

[Necdet]

Merhaba,

Boş durma boşa çalış. Neden örnek dosyanız asıl dosyanızın yapısında olmaz anlamıyorum. Gereksiz yere emek harcatıyorsunuz.

Sub Yaz()
    
    Dim i As Long, _
        j As Integer
        
    Application.ScreenUpdating = False
    For i = 5 To Cells(Rows.Count, "A").End(3).Row
        j = 6 + Cells(i, "F")
        Range(Cells(i, "G"), Cells(i, j)) = Cells(i, "E")
    Next i
    Application.ScreenUpdating = True
    MsgBox "Bitti...."
    
End Sub

 

[nkeles]

Merhaba,

Boş durma boşa çalış. Neden örnek dosyanız asıl dosyanızın yapısında olmaz anlamıyorum. Gereksiz yere emek harcatıyorsunuz.

Sub Yaz()
    
    Dim i As Long, _
        j As Integer
        
    Application.ScreenUpdating = False
    For i = 5 To Cells(Rows.Count, "A").End(3).Row
        j = 6 + Cells(i, "F")
        Range(Cells(i, "G"), Cells(i, j)) = Cells(i, "E")
    Next i
    Application.ScreenUpdating = True
    MsgBox "Bitti...."
    
End Sub

Eyvallah teşükkür ederim. :tongue:

 

[Necdet]

Eyvallah teşükkür ederim. :tongue:

Güle güle kullanınız.:biggrin:

 

[nkeles]

Arkadaşlar merhaba yukarıdaki dosyaya bazı ek isteklerim olacaktı.
Sayfa 1 de adet kadar oluşturduğum verilerin Sayfa 2 ye tek bir sutuna sıralı halde taşınmasını istiyorum. Yardımcı olabilir msiniz. Teşekkürler

 

[Necdet]

Merhaba,

Kodlara ek yaptım, deneyiniz.

Sub Yaz()
    
    Dim i   As Long, _
        j   As Long, _
        Kol As Integer, _
        Hcr As Range
        
    Application.ScreenUpdating = False
    
    For i = 5 To Cells(Rows.Count, "A").End(3).Row
        j = 6 + Cells(i, "F")
        Range(Cells(i, "G"), Cells(i, j)) = Cells(i, "E")
    Next i
    
    i = i - 1
    Kol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    
    MsgBox Kol
    
    j = 1
    
    Sheets("Sayfa2").Range("A:A").ClearContents
    Sheets("Sayfa2").Range("A1") = "Değerler"
    
    For Each Hcr In Range(Cells(5, "G"), Cells(i, Kol))
        If Not Hcr = "" Then
            j = j + 1
            Sheets("Sayfa2").Cells(j, "A") = Hcr
        End If
    Next Hcr
    
    Sheets("Sayfa2").Range("A2:A" & j).Sort Key1:=Sheets("Sayfa2").Range("A1")
    Sheets("Sayfa2").Select
    
    Application.ScreenUpdating = True
    MsgBox "Bitti...."
    
End Sub

 

[nkeles]

Merhaba,

Kodlara ek yaptım, deneyiniz.

Sub Yaz()
    
    Dim i   As Long, _
        j   As Long, _
        Kol As Integer, _
        Hcr As Range
        
    Application.ScreenUpdating = False
    
    For i = 5 To Cells(Rows.Count, "A").End(3).Row
        j = 6 + Cells(i, "F")
        Range(Cells(i, "G"), Cells(i, j)) = Cells(i, "E")
    Next i
    
    i = i - 1
    Kol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    
    MsgBox Kol
    
    j = 1
    
    Sheets("Sayfa2").Range("A:A").ClearContents
    Sheets("Sayfa2").Range("A1") = "Değerler"
    
    For Each Hcr In Range(Cells(5, "G"), Cells(i, Kol))
        If Not Hcr = "" Then
            j = j + 1
            Sheets("Sayfa2").Cells(j, "A") = Hcr
        End If
    Next Hcr
    
    Sheets("Sayfa2").Range("A2:A" & j).Sort Key1:=Sheets("Sayfa2").Range("A1")
    Sheets("Sayfa2").Select
    
    Application.ScreenUpdating = True
    MsgBox "Bitti...."
    
End Sub

Tekrar teşekkürler. İşimde bana çok yardımcı oluyorsunuz. k::k::k::