Soru Farklı Sütunlardaki Verileri Tek Sütunda Toplama

[katip06]

Arkadaşlar kolay gelsin, yapmak istediğim şu, sayfa 1 de A sütunundan AAX sütununa kadar her sütunda farklı adetlerde veriler var, ben örnek olarak birkaç sütunu doldurdum, dolu olan hücrelerdeki verileri sayfa 2 de A sütununa alt alta kopyalamasını istiyorum. Hepinize şimdiden teşekkür ederim.

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub biraraya_topla()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
    
    
sonsat = s1.[A1].SpecialCells(xlLastCell).Row
sonsut = s1.[A1].SpecialCells(xlLastCell).Column

For sut = 1 To sonsut
    yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
    s1.Range(Cells(1, sut), Cells(sonsat, sut)).Copy s2.Cells(yeni, "A")
Next
    s2.Range("A:A").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

    Application.CutCopyMode = False
End Sub

 

[katip06]

Sub biraraya_topla() Set s1 = Sheets("Sayfa1") Set s2 = Sheets("Sayfa2") sonsat = s1.[A1].SpecialCells(xlLastCell).Row sonsut = s1.[A1].SpecialCells(xlLastCell).Column For sut = 1 To sonsut yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1 s1.Range(Cells(1, sut), Cells(sonsat, sut)).Copy s2.Cells(yeni, "A") Next s2.Range("A:A").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp Application.CutCopyMode = False End Sub

Yusuf44 öncelikle emeğin için teşekkürler, şöyle bir sıkıntı var, yeni bir veri girip tekrar makroyu çalıştırdığımda önceki verileri de tekrar atıyo ikinci sayfaya, bunun önüne geçebilirsek tam istediğim gibi olacak.

 

[YUSUF44]

sonsat satırından önce aşağıdaki satırı ekleyip deneyin. Önce Sayfa2'nin A sütununu temizler, sonra tüm verileri aktarır:

s2.Range("A:A").ClearContents

 

[katip06]

s2.Range("A:A").ClearContents

Yusuf44 hocam büyük ihtimal oldu, çok teşekkür ederim, eline emeğine sağlık, hata veren bir yer olursa dönüş yaparım.

 

[katip06]

Yusuf44 hocam büyük ihtimal oldu, çok teşekkür ederim, eline emeğine sağlık, hata veren bir yer olursa dönüş yaparım.

Yusuf44 hocam, peki şöyle bir şey mümkün müdür?
Sütunların 2. satırlarında bulunan verileri alt alta kopyalayacak, sonra yanlarına başlıkta yazanı yazacak, bu verileri Sayfa 2 de A sütununa kopyalayacak.

 

[YUSUF44]

Aşağıdaki gibi deneyin, verilerin çokluğuna göre uzun sürebilir:

Sub biraraya_topla()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s2.Range("A:B").ClearContents
  
sonsat = s1.[A1].SpecialCells(xlLastCell).Row
sonsut = s1.[A1].SpecialCells(xlLastCell).Column

For sut = 1 To sonsut
    son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, sut).End(3).Row)
    For j = 2 To son
        If s1.Cells(j, sut) <> "" Then
            yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
            s2.Cells(yeni, "A") = s1.Cells(j, sut)
            s2.Cells(yeni, "B") = s1.Cells(1, sut)
        End If
    Next
Next
Application.ScreenUpdating = False
MsgBox "İşlem Tamamlandı"
End Sub

 

[katip06]

Aşağıdaki gibi deneyin, verilerin çokluğuna göre uzun sürebilir:

Sub biraraya_topla()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s2.Range("A:B").ClearContents
 
sonsat = s1.[A1].SpecialCells(xlLastCell).Row
sonsut = s1.[A1].SpecialCells(xlLastCell).Column

For sut = 1 To sonsut
    son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, sut).End(3).Row)
    For j = 2 To son
        If s1.Cells(j, sut) <> "" Then
            yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
            s2.Cells(yeni, "A") = s1.Cells(j, sut)
            s2.Cells(yeni, "B") = s1.Cells(1, sut)
        End If
    Next
Next
Application.ScreenUpdating = False
MsgBox "İşlem Tamamlandı"
End Sub

Çok teşekkür ederim Yusuf44 hocam, sağolasın.

 

[YUSUF44]

Bu arada düzeltmeyi unutmuşum. Sondaki False değil True olmalı. True yapıp kodu en az bir kere çalıştırın ki ekran yenileme normale dönsün.

 

[katip06]

Bu arada düzeltmeyi unutmuşum. Sondaki False değil True olmalı. True yapıp kodu en az bir kere çalıştırın ki ekran yenileme normale dönsün.

Teşekkürler Yusuf44 hocam, sağolasın.