Değişken satırları olan tabloyu sayfalara kopyalamak

[ahmet.tmy]

Merhaba;

Günlük gelen fakat satır sayıları ve kişi sıraları farklı olan bir tablo var.
Yapmak istediğim sayfalara kişilerin isimlerini vermek ve her kişiye ait olan bölümü tablonun içinden sayfalara taşımak.

Bunun için yardımlarınızı rica ediyorum.

 

[Necdet]

Merhaba,

Örnek dosya ya da görüntü ile sorunuzu destekleyiniz ki soru net olarak anlaşılsın.

Çok genel anlatımı olan soru ile kimse ilgilenmez.

Örneğin gelen veride sayfa ismi olacak veri hangi sütunda? gibi.
veriniz kaç sütunlu gibi.
vs vs vs

 

[ahmet.tmy]

http://www.dosya.tc/server33/GopdkH/Book1.xlsx.html

Necdet bey;

Yükleme sayfasında gelen bilgi var.
Bu bilgiler günlük olarak değişiyor.Sol tarafta isimler var bu isim sıralaması ve her isimdeki satır müktarı her gün farklılık gösteriyor.
Yapmak istediğim her isme ait olan bilgiyi diğer sayfalara isimlerine göre kopyalamak.

Şimdiden ilginiz için teşekkür ederim.

 

[Emir Hüseyin Çoban]

. . .

Hergün için ayrı bir tablo mu yapıyorsunuz.
Yoksa isimler sayfası sabit kalıp, hergün yükleme sayfasından gelen veriler altınamı eklenecek ?

. . .

 

[ahmet.tmy]

Yükleme sayfasına hergün farklı bilgi geliyor.
Buraya bu bilgileri ben baska bir dosyadan kopyalayıp yapıstırıyorum.
İsim sayfaları sabit kalacak.Ben bu isim sayfalarından oluşturduğum makro ile bilgileri alıp bir tabloya ekliyorum.
Benim aşamadığım nokta yükleme sayfasına yapırtırdığım bilgi her isime ait olan bölümün değişken olması.
mesela
bugün ahmet için olan satır sayısı 25 iken yarın 20 olabiliyor.
bir ikincisi bugun ahmet birinci sırada olurken ertesi gün üçüncü sırada olabiliyor.

Yükleme sayfasındaki genel bilgi içinden isme ait olan bölüm sayfadaki isme ait olan bölüme aktardıktan sonra oluşturduğum makroyu çalıştıracağım.

 

[Emir Hüseyin Çoban]

. . .

Dosyanız ektedir.

...::: Ekli Dosyayı İndirmek İçin Linki Tıklayınız :::...
https://yadi.sk/d/1tVyV8eNWqfRf

Sub Kod()
    Application.ScreenUpdating = False
    Dim Sayfa As String
    Dim SY As Worksheet
    Set SY = Sheets("YÜKLEME")
    
    For a = 1 To SY.[A65536].End(3).Row
        Sayfa = SY.Cells(a, "R")
        If SY.Cells(a, "R") <> "" Then
            If Not SayfaVarMi(Sayfa) Then
                Sheets.Add.Name = Sayfa
                ActiveSheet.Move after:=Sheets(Sheets.Count)
            Else
            End If
        End If
        
        If SY.Cells(a + 1, "R") = "" Then
            SY.Cells(a + 1, "R") = SY.Cells(a, "R")
        End If
    Next a
    a = Empty
    Sayfa = Empty
    SY.Select
    
    For i = 1 To SY.[A65536].End(3).Row
        Sayfa = SY.Cells(i, "R")
        sonsatır = WorksheetFunction.CountA(Sheets(Sayfa).Range("A1:A65536")) + 1
        SY.Range("A" & i & ":Q" & i).Copy Sheets(Sayfa).Cells(sonsatır, "A")
    Next i
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

Function SayfaVarMi(Sayfa As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function

. . .

 

[ahmet.tmy]

Hüseyin bey ;

Çok teşekkür ederim .
Bir konuda daha yardım isteyeceğim sizden
bu sefer hesaba katmadığım başka bir sıkıntı yaşadım .
Açılan sayfaların hep aynı sırada olmasını nasıl sağlayabiliriz.Mesela alfabetik sıra ile olması gibi olabilir mi?

 

[Emir Hüseyin Çoban]

. . .

Tablonuzda Görünüm > Makrolar > Makroları Görüntüle
Açılan ekranda, tablonuzdaki kod isimleri listelenecektir.
İlgili kodu seçip, Seçenekler >
Açılan ekrandan kısayol tanımlaması yapabilirsiniz.

. . .

 

[ahmet.tmy]

Teşekkür ederim
Hüseyin bey ;
Hızınıza hayran kaldım üstadım
mesajı düzeltmeye çalışırken yazdığım önceki mesaja bile cevap vermissiniz
sıralama konusunda da sızden yardım alabilirsem çok mutlu olacağım.

 

[Emir Hüseyin Çoban]

. . .

Kodlara ilave yaptım.
Sy Orion2' nin daha önce paylaşmış olduğu kodları kullandım.

Option Base 1
Sub Kod()
    Application.ScreenUpdating = False
    Dim Sayfa As String
    Dim SY As Worksheet
    Set SY = Sheets("YÜKLEME")
    
    For a = 1 To SY.[A65536].End(3).Row
        Sayfa = SY.Cells(a, "R")
        If SY.Cells(a, "R") <> "" Then
            If Not SayfaVarMi(Sayfa) Then
                Sheets.Add.Name = Sayfa
                ActiveSheet.Move after:=Sheets(Sheets.Count)
            Else
            End If
        End If
        
        If SY.Cells(a + 1, "R") = "" Then
            SY.Cells(a + 1, "R") = SY.Cells(a, "R")
        End If
    Next a
    a = Empty
    Sayfa = Empty
    SY.Select
    
    For i = 1 To SY.[A65536].End(3).Row
        Sayfa = SY.Cells(i, "R")
        sonsatır = WorksheetFunction.CountA(Sheets(Sayfa).Range("A1:A65536")) + 1
        SY.Range("A" & i & ":Q" & i).Copy Sheets(Sayfa).Cells(sonsatır, "A")
    Next i
    i = Empty
    [COLOR="SeaGreen"]'''''[/COLOR]
    ReDim myarr(1 To 1, 1 To Worksheets.Count)
    For i = 1 To Worksheets.Count
        myarr(1, i) = Sheets(i).Name
    Next i
    For i = 1 To UBound(myarr, 2) - 1
        For j = i + 1 To UBound(myarr, 2)
            If StrComp(myarr(1, i), myarr(1, j), vbTextCompare) = 1 Then
                x = myarr(1, j)
                myarr(1, j) = myarr(1, i)
                myarr(1, i) = x
            End If
        Next j
    Next i
    For i = 1 To UBound(myarr, 2)
        Sheets(myarr(1, i)).Move after:=Sheets(Worksheets.Count)
    Next
[COLOR="SeaGreen"]    '''''[/COLOR]
    SY.Move Before:=Sheets(1)
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

Function SayfaVarMi(Sayfa As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function

. . .

 

[ahmet.tmy]

hüseyin bey;
teşekkür ederim beni büyük dertten kurtardınız