sayfalar arası dolu olan bölgelerin aktarımı

[kakara]

merhaba ustadlarım sayfa1 de dolu alanların sayfa ıkıye aktarılması ıle ılgılı yardımınıza ıhtıyacım var eklı dosyada detayları ve olması gereken seklı hazırladım ılgınız ıcın sımdıden tesekkurler

 

[kakara]

problem devam etmekte ılgınız ıcın tesekkurler.

 

[kakara]

yaklasık 100 göruntulenme almıs olması ımkansız bırsey mı ıstedım sanırım yınede ılgınız ıcın tesekkur ederım.

 

[ÖmerFaruk]

Dosyanızda anlatımınızda eksikler var ya da ben anlayamadım.
Mesela 1.üründe
hem M hem de T hem de AA sütunlarında veri varsa ve buralara ait ORDER COLOR kısımlarında sayı varsa ne olacak?

 

[kakara]

@ÖmerFaruk ustadım o zaman uc tabloda arka sayfaya gelecek yanı soyle women pıjama ve order colorlardan hangılerı doluysa yıne aynı no ya aıt women xl bolumununde rakam yazıyorsa onlarda arka sayfaya gelıcek eğer sayfa2 ye bakma ımkanınız olduysa olması gerekenın sablonunu yapmaya calıstım sızlere. aslında sadece order color kısmı degıl order kısmına aıt descripsion price size asorti kısmınlarıyla bırlıkte cekmek ıstıyorum. işallah size anlatabılmısımdır. zamanınız olur bakabılırsenız anlayamadıgınız kısmı tekrar anlatmaya calısırım ılgınız ıcın tesekkur ederım

 

[ÖmerFaruk]

Sayfa2 deki tablonuzun doğru olduğuna eminmisiniz?
Anlattıklarınızla sayfa2 yi örtüştüremiyorum.
Rica etsem Sayfa1 de 10-15 satır veri doldurup, sayfa2 de ne görmek istediğinizi manuel olarak oluşturur musunuz?

 

[kakara]

sayfa ıkıde anlatmaya calıstım @ÖmerFaruk ustadım ısallah rıcam yapılacak bırseydır. ılgınız ıcın tesekkur ederım

 

[ÖmerFaruk]

Dosyanıza sayfa3 ekleyin.
Sayfa1 açıkken aşağıdaki kodları çalıştırın.

Sub YeniListe()
Dim Dizi
    Set Dizi = CreateObject("Scripting.Dictionary")
    SonSut = Range("XFD1").End(xlToLeft).Column
    SonSat = Range("A" & Rows.Count).End(xlUp).Row
    Dizi = Range("A2").Resize(SonSat - 1, SonSut).Value
    ReDim Liste(1 To SonSat - 1, 1 To SonSut)
    For i = 1 To SonSat - 1
        SatırOk = False
        Yaz = 6
        For k = 13 To SonSut Step 7
            Topla = 0
            Topla = Dizi(i, k + 4) + Dizi(i, k + 5) + Dizi(i, k + 6)
            If Topla > 0 Then
                If SatırOk = False Then
                    SatırOk = True
                    Say = Say + 1
                    For x = 1 To 12
                        Liste(Say, x) = Dizi(i, x)
                    Next x
                End If
                Yaz = Yaz + 7
                For j = 0 To 6
                    Liste(Say, Yaz + j) = Dizi(i, k + j)
                Next j
            End If
            MaxSütun = WorksheetFunction.Max(MaxSütun, Yaz + 6)
        Next k
    Next i
    Worksheets("Sayfa3").Cells.Clear
    If Say > 0 Then
        Worksheets("Sayfa3").Range("A1:L1") = Range("A1:L1")
        Range("A1:L1").Copy Worksheets("Sayfa3").Range("A1:L1")
        For x = 13 To MaxSütun Step 7
            Range("M1:S1").Copy Worksheets("Sayfa3").Range("A1").Offset(0, x - 1).Resize(1, 7)
        Next x
        Worksheets("Sayfa3").Range("A2").Resize(Say, MaxSütun) = Liste
    End If
End Sub

 

[kakara]

@ÖmerFaruk ustadım ılgınız ıcın cok tesekkurler detaylı kontrol edıp sıze gerı donus yapıcam tesekkurler.

 

[kakara]

@ÖmerFaruk ustadım kodlarını calısıyor ılgınız ıcın tesekkurler. yaptıgımız calısmada sayfa3 te ıstedıgımız gıbı bır sonuc alıyoruz fakat sayfa 4 e aynı numarada olan sıparıslerı alt alta getırebılır mıyız ? eklı dosyanın sayfa 3 de detaylı bır calısma hazırladım, vaktınızı ve ilginizi ayırdıgınız ıcın tesekkurler

 

[ÖmerFaruk]

Dosyanıza Sayfa4 ekleyin.
Module1 içine aşağıdaki kodları yapıştırın.
Sayfa1 içindeyken çalıştırabilrisiniz.

Renk karmaşası olmasın diye formatı kendi zevkime göre düzenledim.

Sub YeniListe2()
'Ürün numaralarına göre alt alta yeni satıra yazılıyor
Dim Dizi, Liste
Dim Say As Integer, k As Integer, x As Integer, Topla As Long
Dim SonSat As Long, SonSut As Integer
Dim ilk As Integer, Renk As Byte

    If ActiveSheet.Name <> "Sayfa1" Then Exit Sub
    Set Dizi = CreateObject("Scripting.Dictionary")
    Dizi = Range("A1").Resize(Range("A" & Rows.Count).End(xlUp).Row, Range("XFD1").End(xlToLeft).Column).Value
    ReDim Liste(1 To Rows.Count, 1 To UBound(Dizi, 2) + 1)
    For i = 2 To UBound(Dizi, 1)
        For k = 13 To Range("XFD1").End(xlToLeft).Column Step 7
            Topla = Dizi(i, k + 4) + Dizi(i, k + 5) + Dizi(i, k + 6)
            If Topla > 0 Then
                Say = Say + 1
                For x = 1 To 12
                    Liste(Say, x) = Dizi(i, x)
                Next x
                For x = 0 To 6
                    Liste(Say, 13 + x) = Dizi(i, k + x)
                Next x
            End If
        Next k
    Next i
    Worksheets("Sayfa4").Cells.Clear
    If Say > 0 Then
        Range("A1:S1").Copy Worksheets("Sayfa4").Range("A1:S1")
        Worksheets("Sayfa4").Range("A2").Resize(Say, 19) = Liste
    End If
   
    'Kenarlık ve renklendirme
    'Her bilgisayda renkler farklı olduğu seçtiğiniz ofis temasının renklerine göre ayarladım
    With Worksheets("Sayfa4")
    ilk = 2
    Renk = 0
    For i = 1 To Say
        If Liste(i, 1) <> Liste(i + 1, 1) Then
            .Range("A" & ilk).Resize(i - ilk + 1, 19).BorderAround ColorIndex:=0, Weight:=xlThin
            If Renk = 1 Then
                .Range("A" & ilk).Resize(i - ilk + 1, 19).Interior.ThemeColor = xlThemeColorDark1
                Renk = 0
            Else
                .Range("A" & ilk).Resize(i - ilk + 1, 19).Interior.ThemeColor = xlThemeColorDark2
                Renk = 1
            End If
            ilk = i + 1
        End If
    Next i
    .Range("A1").Resize(1, 19).BorderAround ColorIndex:=0, Weight:=xlThin
    .Range("A1").Resize(Say + 1, 19).BorderAround ColorIndex:=0, Weight:=xlThick
    End With
End Sub

 

[kakara]

@ÖmerFaruk ustadım ilginiz için tesekkurler verdıgınız kod calısıyor