Soru ch extrelerini sayfalara aktarma

[NADİR YILDIZ]

Arkadaşlar
burada yapmak istediğim şöyle;
zirve sayfasında karışık olan extreleri
şablon sayfası başlığı gibi olacak şekilde ayrı ayrı sayfalar açarak aktarmak
aktardığı bu sayfaları sayfa isimleri sekmesinde alt hesap adı ve alt hesap kodu şeklinde listelemesi
aynı zamanda bu listedekileride ilgili ch hesap extresi sayfasıyla köprü oluşturması
yine her extre aktarımında sayfaları silerek yeniden cari isimde sayfa oluşturması
zirve sayfasındaki extreler bu kadar değil 400 - 500 tane olabiliyor.

sizlerden çok şey istiyorum biliyorum.
kademe kademe gidersek bu çalışmada yardımcı olur musunuz

iyi çalışmalar

 

[NADİR YILDIZ]

arkadaşlar bu konuda yardım edebilecekmisiniz ?

 

[mancubus]

yedek bir dosyada deneyin.
dosyada sadece zirve ve sayfa isimleri sayfaları kalsın.
dosya bu halde iken ana dosya olsun. her extre dönemi için (örneğin. ch_ekstre_2021_ekim) ayrı bir isimle çoğaltırsınız.

firma sayfalarına de sayfa isimlkeri sayfasına geri dönmeyi sağlayacak köprü eklenmiştir. 500 vb firma ile buna ihtiyacınız olur.
çıktı alınacaksa yazı rengi beyaz yapılabilir.

 

[mancubus]

Sub xlTR_196968_ch_extrelerini_sayfalara_aktarma()

    Dim cll As Range, arRow As Range
    Dim i As Long, j As Long, cnt As Long, iSat As Long, sSat As Long, xSat As Long
    Dim frmArr
    Dim hsp As String
    Dim wsAna As Worksheet, wsInd As Worksheet

    Application.ScreenUpdating = False
    
    Set wsAna = Worksheets("Zirve")
    
    Set wsInd = Worksheets("SAYFA İSİMLERİ")
    wsInd.UsedRange.Offset(1).ClearContents
    
    With wsAna
        .AutoFilterMode = False
        .UsedRange.AutoFilter Field:=1, Criteria1:="=Alt Hesap Kodu :"
        With .AutoFilter.Range
            Set rng = .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible)
        End With
        .AutoFilterMode = False
    End With

    'filtrelenmiş alanca firma sayısını (=başlık satırı hariç filtrelenmiş alan satır saysı) bul
    cnt = 0
    For Each cll In rng.Areas
        cnt = cnt + cll.Rows.Count
    Next cll
    
    'başlık satırı hariç filtrelenmiş alanın 4 sütununu dizi değişkenine ata
    ReDim frmArr(1 To cnt, 1 To 4)
    cnt = 0
    For Each cll In rng.Areas
        For Each arRow In cll.Rows
            cnt = cnt + 1
            For j = 1 To 4
                frmArr(cnt, j) = CStr(arRow.Cells(j).Value)
            Next j
        Next arRow
    Next cll

    'dizi değişkeninin 2. ve 4. sütunundaki değerlere göre yeni sayfa oluştur, sayfaları bu iki sütuna göre isimlendir
    'zirve sayfasındaki verilerini bu sayfalara kopyala, index sayfasında köprüleri oluştur
    For i = LBound(frmArr, 1) To UBound(frmArr, 1)
        hsp = Left(frmArr(i, 2) & "_" & frmArr(i, 4), 31)
        'hsp = Left(frmArr(i, 4), 31)
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = hsp
        
        With wsInd
            xSat = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
            .Range("A" & xSat).Value = "'" & CStr(frmArr(i, 2))
            .Range("B" & xSat).Value = frmArr(i, 4)
            .Hyperlinks.Add .Range("B" & xSat), "", "'" & Worksheets(hsp).Name & "'!A1"
        End With
        
        With wsAna
            iSat = Application.Match(frmArr(i, 2), .Columns(2), 0)
            sSat = .Range("B" & iSat).End(xlDown).Offset(2).Row
            .Range("A" & iSat & ":M" & sSat).Copy
        End With
        
        With Worksheets(hsp)
            .Cells(1).PasteSpecial
            Application.CutCopyMode = False
            .Columns.AutoFit
            .Hyperlinks.Add .Range("F1"), "", "'" & wsInd.Name & "'" & "!A1"
        End With
    Next i

End Sub

 

[NADİR YILDIZ]

Sayın mancubus aklınıza emeğinize sağlık tam istediğim gibi

ancak ben birşeyi atladım özür dileyerek o konuda da yardımcı olabilirmisiniz

sayfa isimleri sekmesine borç alacak ve bakiye tutarlarınıda getirebilirmiyiz

iyi çalışmalar

 

[mancubus]

rica ederim.
aslında diğer verilerin getirilişinden farklı değil.
bu defa hücreden diziye aktarılmış verilerden değil, doğrudan firma extrelerinin JKL sütunlarının en alt satındaki verileri aktaracaksınız.
tabii SAYFA İSİMLERİ sayfası ile ilgili kodları ekstre sayfası ile ilgili kodların altına almak gerekecek.

 

[mancubus]

Sub xlTR_196968_ch_extrelerini_sayfalara_aktarma()

    Dim cll As Range, arRow As Range
    Dim i As Long, j As Long, cnt As Long, iSat As Long, sSat As Long, xSat As Long
    Dim mBorc As Double, mAlacak As Double, mBakiye As Double
    Dim frmArr
    Dim hsp As String
    Dim wsAna As Worksheet, wsInd As Worksheet

    Application.ScreenUpdating = False
 
    Set wsAna = Worksheets("Zirve")
 
    Set wsInd = Worksheets("SAYFA İSİMLERİ")
    wsInd.UsedRange.Offset(1).ClearContents
 
    With wsAna
        .AutoFilterMode = False
        .UsedRange.AutoFilter Field:=1, Criteria1:="=Alt Hesap Kodu :"
        With .AutoFilter.Range
            Set rng = .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible)
        End With
        .AutoFilterMode = False
    End With

    'filtrelenmiş alanda firma sayısını (=başlık satırı hariç filtrelenmiş alan satır sayısı) bul
    cnt = 0
    For Each cll In rng.Areas
        cnt = cnt + cll.Rows.Count
    Next cll
 
    'başlık satırı hariç filtrelenmiş alanın 4 sütununu dizi değişkenine ata
    ReDim frmArr(1 To cnt, 1 To 4)
    cnt = 0
    For Each cll In rng.Areas
        For Each arRow In cll.Rows
            cnt = cnt + 1
            For j = 1 To 4
                frmArr(cnt, j) = CStr(arRow.Cells(j).Value)
            Next j
        Next arRow
    Next cll

    'dizi değişkeninin 2. ve 4. sütunundaki değerlere göre yeni sayfa oluştur, sayfaları bu iki sütuna göre isimlendir
    'zirve sayfasındaki verilerini bu sayfalara kopyala, index sayfasında köprüleri oluştur
    For i = LBound(frmArr, 1) To UBound(frmArr, 1)
        hsp = Left(frmArr(i, 2) & "_" & frmArr(i, 4), 31)
        'hsp = Left(frmArr(i, 4), 31)
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = hsp
     
        With wsAna
            iSat = Application.Match(frmArr(i, 2), .Columns(2), 0)
            sSat = .Range("B" & iSat).End(xlDown).Offset(2).Row
            .Range("A" & iSat & ":M" & sSat).Copy
        End With
     
        With Worksheets(hsp)
            .Cells(1).PasteSpecial
            Application.CutCopyMode = False
            .Columns.AutoFit
            .Hyperlinks.Add .Range("F1"), "", "'" & wsInd.Name & "'" & "!A1"
            .Range("F1").Value = "Sayfa İsimleri Sayfasına Dön"
            mBorc = .Range("J" & .Rows.Count).End(xlUp).Value
            mAlacak = .Range("K" & .Rows.Count).End(xlUp).Value
            mBakiye = .Range("L" & .Rows.Count).End(xlUp).Value
        End With
 
        With wsInd
            xSat = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
            .Range("A" & xSat).Value = "'" & CStr(frmArr(i, 2))
            .Range("B" & xSat).Value = frmArr(i, 4)
            .Hyperlinks.Add .Range("B" & xSat), "", "'" & Worksheets(hsp).Name & "'!A1"
            .Range("C" & xSat).Value = mBorc
            .Range("D" & xSat).Value = mAlacak
            .Range("E" & xSat).Value = mBakiye
        End With
    Next i

End Sub

 

[NADİR YILDIZ]

çok teşekkür ediyorum
iyi çalışmalar

 

[mancubus]

rica ederim. kolay gelsin.