• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Plaka bazlı yazdırma

mzsakall

mzsakall

Altın Üye
Katılım
6 Şubat 2018
Mesajlar
110
Excel Vers. ve Dili
Excel 2010
Sayın ilgililer
Ekte hazırladığım dosyada saatlik çıkana araçları yazdırmaktayım ancak detay sayfasından liste sayfasına ilgili plakaların yüklü olduğu mağaza adlarını yanyana yazdırmak ve detay sayfasında ki D stünına göre saatlerini getirmek istiyorum nu hakkında yardımcı olur musunuz
 
Okudum, yardımcı olayım dedim ancak, anlayamadım.
Ne yapmak istediğinizi, biraz daha net ifadelerle açıklar mısınız?
 
DEtay sayfasında olan verilerden B sütununda ki plakaların liste sayfasına saat dilimlerine göre 08:10 10:12 aralıklarında yazılması e sütununa plakaya göre detayda ki c stünunun verilerinin gelmesi listede yazan f g sütunlara detay sayfasında ki D e sütunlarında ki verilen gelmesi ve plakaya göre liste sayfasına sefer sayfasında ki aracın gittiği mağazaların yanyana yazdırılmasını istiyorum biraz karışık yardımınız için teşekkür ederim mağazaları getirirken detay sayfasında ki A sütununda bulunan sefer numarasından faydalanıp sefer sayfasında ki sefer numarasına ait mağazaları getirebiliriz
 
iste sayfasına saat dilimlerine göre 08:10 10:12 ....demişsiniz
Kapanma Saati mi? Çıkış Saati mi?
 
Bazen 08:10 arası 10 araç bazen 1 araç çıkıyor liste genişliğini kendide ayarlama yaparsa mükemmel olur
 
Mağazaları getirirken detay sayfasında bulunan A sütunu sefer numarasına göre getirmesi lazım çünkü aynı araç 2-3 sefer yapabiliyor sefer numarasına göre detay sayfasına sefer sayfası B sütunundan alması lazım ki doğru veri olsun
 
LİSTE sayfasının kod bölümüne aşağıdakini koyabilirsiniz.
Ayrıca dosyanızı da ekledim.
Sizin dosyanızdaki Sefer ve Detay sayfaları sıralı olarak geldiği için ben yeniden sıralama yaptırmadım.
Kenarlıkları ve birleştirmeleri otomatik yaptırıyoruz. G sütunundaki formüllerinizi sildim. Bekleme Süresini kodlarla yaptırıyoruz.
Satır yüksekliklerini otomatik ayarladık
Verilerinizin kaybolmaması için yedek almayı unutmayın.

C++: 
Private Sub Worksheet_Activate()
    Set Sh1 = Worksheets("DETAY")
    Set Sh2 = Worksheets("ARAÇ STD")
    Set Sh3 = Worksheets("SEFER")
    Dolu = WorksheetFunction.CountA(Columns(3)) - 1
    If Dolu > 1 Then Rows("2:" & Dolu + 1).Delete 'Eski listeyi komple kaldır
    Say = WorksheetFunction.CountA(Sh1.Columns(1))
    If Say < 2 Then Exit Sub
    Sh1.Range("B2:B" & Say).Copy ' Detay sayfasından verileri al ve sadece değerleri yapıştır
    Range("C2:C" & Say).PasteSpecial xlPasteValues
    Sh1.Range("C2:E" & Say).Copy  Detay sayfasından verileri al ve sadece değerleri yapıştır
    Range("E2:G" & Say).PasteSpecial xlPasteValues
    For i = 2 To Say ' Saat dilimlerini belirle
        Cells(i, 8) = Cells(i, 7) - Cells(i, 6)
        Select Case Hour(Range("F" & i))
            Case Is < 10
            Cells(i, 1) = "08:00 - 10:00"
            Case Is < 12
            Cells(i, 1) = "10:00 - 12:00"
            Case Is < 14
            Cells(i, 1) = "12:00 - 14:00"
            Case Is < 16
            Cells(i, 1) = "14:00 - 16:00"
            Case Else
            Cells(i, 1) = "16:00 - 19:00"
        End Select   
    Next i
    Rows("2:" & Say).RowHeight = 18 'Satır Yükseklikleri
    ' Mağaza adlarını ilave et
    For i = 1 To Sh3.Cells(1, 1).End(xlDown).Row
        For k = 2 To Say
            If Sh3.Cells(i, 2) = Sh1.Cells(k, 1) Then
                Cells(k, WorksheetFunction.CountA(Range("J" & k, "R" & k)) + 10) = Sh3.Cells(i, 5)
                Exit For
            End If
        Next k
    Next i
    Application.DisplayAlerts = False
    For i = 2 To Say
        For k = i To Say
        If Cells(i, 1) <> Cells(k, 1) Then
            GoTo Devam1

        End If
        Next k
Devam1:
            Range(Cells(i, 1), Cells(k - 1, 1)).Merge ' Saatleri birleştirdik
            Range(Cells(i, 2), Cells(k - 1, 2)).Merge ' Yüklenen sayı birleşti
            Range("A" & i, "R" & k - 1).BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic ' Saat dilimindeki kalın dış kenarlıklar
            Range("A" & i, "R" & k - 1).Borders(xlInsideVertical).Weight = xlThin ' Saat dilimindeki dikey iç kenarlık
            Range("A" & i, "R" & k - 1).Borders(xlInsideHorizontal).Weight = xlThin ' Saat dilimindeki yatay iç kenarlık
            i = k - 1
    Next i
        Application.DisplayAlerts = True
End Sub
 
Merhaba ellerinize sağlık tam istediğim gibi B sütuna c sütununda ilgili saatte çıkan araçları toplarıp en alta çıkan toplam araçları yazabilir mi
 
Sayın ilgili liste D sayfasına plakalar sayfasından araç kapasitelerini getirebilir miyiz son olarak
 
C++: 
Private Sub Worksheet_Activate()
    Set Sh1 = Worksheets("DETAY")
    Set Sh2 = Worksheets("ARAÇ STD")
    Set Sh3 = Worksheets("SEFER")
    Dolu = WorksheetFunction.CountA(Columns(3)) - 1
    If Dolu > 1 Then Rows("2:" & Dolu + 1).Delete

    If Dolu > 1 Then Range("C2:C" & Dolu).ClearContents: Range("J2:R" & Dolu).ClearContents
    Say = WorksheetFunction.CountA(Sh1.Columns(1))
    If Say < 2 Then Exit Sub
    Sh1.Range("B2:B" & Say).Copy
    Range("C2:C" & Say).PasteSpecial xlPasteValues
    Sh1.Range("C2:E" & Say).Copy
    Range("E2:G" & Say).PasteSpecial xlPasteValues
    For i = 2 To Say
        Cells(i, 8) = Cells(i, 7) - Cells(i, 6)
        Select Case Hour(Range("F" & i))
            Case Is < 10
            Cells(i, 1) = "08:00 - 10:00"
            Case Is < 12
            Cells(i, 1) = "10:00 - 12:00"
            Case Is < 14
            Cells(i, 1) = "12:00 - 14:00"
            Case Is < 16
            Cells(i, 1) = "14:00 - 16:00"
            Case Else
            Cells(i, 1) = "16:00 - 19:00"
        End Select
            
    Next i
    Rows("2:" & Say).RowHeight = 18
    For i = 1 To Sh3.Cells(1, 1).End(xlDown).Row
        For k = 2 To Say
            If Sh3.Cells(i, 2) = Sh1.Cells(k, 1) Then
                Cells(k, WorksheetFunction.CountA(Range("J" & k, "R" & k)) + 10) = Sh3.Cells(i, 5)
                Exit For
            End If
        Next k
    Next i
    Application.DisplayAlerts = False
    For i = 2 To Say
        For k = i To Say
        If Cells(i, 1) <> Cells(k, 1) Then
            GoTo Devam1

        End If
        Next k
Devam1:
            Range(Cells(i, 1), Cells(k - 1, 1)).Merge
            Range(Cells(i, 2), Cells(k - 1, 2)).Merge
            Range("B" & i) = k - i 'B sütunundaki çıkan araç sayısı
            Range("A" & i, "R" & k - 1).BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
            Range("A" & i, "R" & k - 1).Borders(xlInsideVertical).Weight = xlThin
            Range("A" & i, "R" & k - 1).Borders(xlInsideHorizontal).Weight = xlThin
            i = k - 1
    Next i
        Application.DisplayAlerts = True
End Sub
Kod:

"... D sayfasına plakalar sayfasından araç kapasitelerini getirebilir miyiz son olarak "
kapasitelerin nerede yazılı olduğunu söylerseniz ekleriz.
 
11. Mesajımda eklediğim dosyada yazılı çok teşekkürler
 
C++: 
Private Sub Worksheet_Activate()
    Set Sh1 = Worksheets("DETAY")
    Set Sh2 = Worksheets("ARAÇ STD")
    Set Sh3 = Worksheets("SEFER")
    Dolu = WorksheetFunction.CountA(Columns(3)) - 1
    If Dolu > 1 Then Rows("2:" & Dolu + 1).Delete

    If Dolu > 1 Then Range("C2:C" & Dolu).ClearContents: Range("J2:R" & Dolu).ClearContents
    Say = WorksheetFunction.CountA(Sh1.Columns(1))
    If Say < 2 Then Exit Sub
    Sh1.Range("B2:B" & Say).Copy
    Range("C2:C" & Say).PasteSpecial xlPasteValues
    Sh1.Range("C2:E" & Say).Copy
    Range("E2:G" & Say).PasteSpecial xlPasteValues
    For i = 2 To Say
        Cells(i, 8) = Cells(i, 7) - Cells(i, 6)
        Select Case Hour(Range("F" & i))
            Case Is < 10
            Cells(i, 1) = "08:00 - 10:00"
            Case Is < 12
            Cells(i, 1) = "10:00 - 12:00"
            Case Is < 14
            Cells(i, 1) = "12:00 - 14:00"
            Case Is < 16
            Cells(i, 1) = "14:00 - 16:00"
            Case Else
            Cells(i, 1) = "16:00 - 19:00"
        End Select
            
    Next i
    Rows("2:" & Say).RowHeight = 18
    For i = 1 To Sh3.Cells(1, 1).End(xlDown).Row
        For k = 2 To Say
            If Sh3.Cells(i, 2) = Sh1.Cells(k, 1) Then
                Cells(k, WorksheetFunction.CountA(Range("J" & k, "R" & k)) + 10) = Sh3.Cells(i, 5)
                Exit For
            End If
        Next k
    Next i
    Application.DisplayAlerts = False
    For i = 2 To Say
        Range("D" & i) = WorksheetFunction.VLookup(Range("C" & i), Worksheets("PLAKALAR").Range("A:B"), 2, 0)
    Next i
     For i = 2 To Say
        For k = i To Say
        If Cells(i, 1) <> Cells(k, 1) Then
            GoTo Devam1

        End If
        Next k
Devam1:
            Range(Cells(i, 1), Cells(k - 1, 1)).Merge
            Range(Cells(i, 2), Cells(k - 1, 2)).Merge
            Range("B" & i) = k - i 'B sütunundaki çıkan araç sayısı
            Range("D" & i) = WorksheetFunction.VLookup(Range("C" & i), Worksheets("PLAKALAR").Range("A:B"), 2)
            Range("A" & i, "R" & k - 1).BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
            Range("A" & i, "R" & k - 1).Borders(xlInsideVertical).Weight = xlThin
            Range("A" & i, "R" & k - 1).Borders(xlInsideHorizontal).Weight = xlThin
            i = k - 1
    Next i
        Application.DisplayAlerts = True
End Sub
 
Sayın next level merhaba

Liste sayfasına eklediğim sütunlara istenlien verileri getirtebilir miyiz
Doluluk hücresine içinde yazan hesaplamayı yapması yüzde olarak yazması k l m n sütunlarında araç std sayfası f sütununda koşullu arama yapması ve k l m n hücrelerinde ki verileri j ye yazmsı ayrıca p sütununa araçta ki ma
 
P sütununa araçta ki yüklü mağaza sayılarını yazdırabilir miyiz
 
Kodları aşağıdakiyle değiştirin.

C++: 
Private Sub Worksheet_Activate()
    Set Sh1 = Worksheets("DETAY")
    Set Sh2 = Worksheets("ARAÇ STD")
    Set Sh3 = Worksheets("SEFER")
    Dolu = WorksheetFunction.CountA(Columns(3)) - 1
    If Dolu > 1 Then Rows("2:" & Dolu + 1).Delete

    If Dolu > 1 Then Range("C2:C" & Dolu).ClearContents: Range("K2:S" & Dolu).ClearContents
    Say = WorksheetFunction.CountA(Sh1.Columns(1))
    If Say < 2 Then Exit Sub
    Sh1.Range("B2:B" & Say).Copy
    Range("C2:C" & Say).PasteSpecial xlPasteValues
    Sh1.Range("C2:E" & Say).Copy
    Range("E2:G" & Say).PasteSpecial xlPasteValues
    For i = 2 To Say
        Cells(i, 8) = Cells(i, 7) - Cells(i, 6)
        Select Case Hour(Range("F" & i))
            Case Is < 0
            Cells(i, 1) = "00:00 - 02:00"
            Case Is < 2
            Cells(i, 1) = "02:00 - 04:00"
            Case Is < 4
            Cells(i, 1) = "04:00 - 06:00"
            Case Is < 7
            Cells(i, 1) = "06:00 - 07:00"
            Case Is < 8
            Cells(i, 1) = "07:00 - 08:00"
        End Select
            
    Next i
    Rows("2:" & Say).RowHeight = 18
    For i = 1 To Sh3.Cells(1, 1).End(xlDown).Row
        For k = 2 To Say
            If Sh3.Cells(i, 2) = Sh1.Cells(k, 1) Then
                Cells(k, WorksheetFunction.CountA(Range("R" & k, "Z" & k)) + 18) = Sh3.Cells(i, 5)
                Exit For
            End If
        Next k
    Next i
    Application.DisplayAlerts = False
    For i = 2 To Say
        Range("D" & i) = WorksheetFunction.VLookup(Range("C" & i), Worksheets("PLAKALAR").Range("A:B"), 2, 0)
    Next i
     For i = 2 To Say
        For k = i To Say
        If Cells(i, 1) <> Cells(k, 1) Then
            GoTo Devam1

        End If
        Next k
Devam1:
            Range(Cells(i, 1), Cells(k - 1, 1)).Merge
            Range(Cells(i, 2), Cells(k - 1, 2)).Merge
            Range("B" & i) = k - i 'B sütunundaki çıkan araç sayısı
            Range("D" & i) = WorksheetFunction.VLookup(Range("C" & i), Worksheets("PLAKALAR").Range("A:B"), 2, 0)
            Range("A" & i, "R" & k - 1).BorderAround xlContinuous, xlMedium, xlColorIndexAutomatic
            Range("A" & i, "R" & k - 1).Borders(xlInsideVertical).Weight = xlThin
            Range("A" & i, "R" & k - 1).Borders(xlInsideHorizontal).Weight = xlThin
            i = k - 1
    Next i
    SonSatır = Sh2.Cells(Rows.Count, 1).End(xlUp).Row
    Dim AlanPlaka As Range
    Set AlanPlaka = Sh2.Range("A2:A" & SonSatır)
    Set AlanYük = Sh2.Range("F2:F" & SonSatır)
    For i = 2 To Say
        Range("I" & i) = 100 * Range("E" & i) / Trim(Replace(Range("D" & i), "PLT", "")) / 70
        For k = 2 To SonSatır
            If Sh2.Range("A" & k) = Range("C" & i) Then
                If Left(Sh2.Range("F" & k), 3) = "DGP" Then
                    Range("K" & i) = Range("K" & i) + 1
                    GoTo Devam2
                End If
                If Left(Sh2.Range("F" & k), 3) = "TZP" Or Left(Sh2.Range("F" & k), 3) = "TSP" Or Left(Sh2.Range("F" & k), 2) = "SR" Then
                    Range("L" & i) = Range("L" & i) + 1
                    GoTo Devam2
                End If
                 If Left(Sh2.Range("F" & k), 3) = "MSP" Or Left(Sh2.Range("F" & k), 3) = "ORG" Then
                    Range("M" & i) = Range("M" & i) + 1
                    GoTo Devam2
                End If
                 If Left(Sh2.Range("F" & k), 3) = "SPP" Or Left(Sh2.Range("F" & k), 3) = "MLP" Then
                    Range("N" & i) = Range("N" & i) + 1
                End If
            End If
Devam2:
        Next k
        Range("J" & i) = WorksheetFunction.Sum(Range("K" & i, "N" & i))
        Range("P" & i) = WorksheetFunction.CountA(Range("R" & i, "Z" & i))
    Next i
    
        Application.DisplayAlerts = True
End Sub
 
Next level bey hata veriyor ama nasıl yapalım
 
Tamam halllettim çok teşekkürler
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst