• DİKKAT

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

imalat km takip

M

modoste

Altın Üye
Katılım
31 Mayıs 2008
Mesajlar
3,714
Excel Vers. ve Dili
Microsoft OFFİCE Ev ve İş 2019 TR
merhaba sayın hocalarım
bu soru grubu ile ilgili 7-8 sene önceki işimde birkaç sorum olmuştu. şimdi tekrar başka bir soru ekli dosyamda ilettim

kısaca anlatırsam:
yolda üst üste serilen tabakalar var. belirli tarihlerde belirli kilometreler arasına imalat yapılıyo.
bu imalat bilgilerini şekilsel takip (grafiğe benzer) yaparak takip edebiliyoruz ama manuel

belirli 2 tarih arası hangi tabakalardan hangi km ler arası ne kadar imalat yapıldığını karelajlı yerde göstermekle ilgili bir soru
 

Ekli dosyalar

Dosyanız üzerinde bir çözüm uyguladım. İnceleyin.
Ayrıca çözülmüş halini de dosya olarak ekledim

C++: 
Private Sub CommandButton1_Click()
    Application.DisplayAlerts = False
    '......
    'Öncelikle mevcut grafik alanını temizleyelim
    ilk = 10
    Son = WorksheetFunction.CountA(Rows("5")) - 1
    SonSat = Range("I" & Application.Rows.Count).End(xlUp).Row
    With Range(Cells(6, ilk), Cells(SonSat, Son))
        .UnMerge
        .ClearContents
        .Borders.LineStyle = xlNone
        .Interior.Color = xlNone
    End With
    '.....
    'Listeye göre yeniden grafik alanını düzenleyelim
    For i = 7 To Range("C7").End(xlDown).Row
        Satır = WorksheetFunction.Match(Cells(i, 4), Range("I:I"), 0)
        ilk = Range("E" & i) / 10
        If ilk = 0 Then
            ilk = ilk + 10
        Else
            ilk = ilk + 11
        End If
        Son = Range("F" & i) / 10 + 10
        Cells(Satır, ilk) = Cells(i, 7) & " / (" & Cells(i, 3) & ")"
        With Range(Cells(Satır, ilk), Cells(Satır, Son))
            .HorizontalAlignment = xlCenter
            .Merge
            .BorderAround xlContinuous, xlThin
            .Interior.Color = Range("D" & i).Interior.Color ' Listede belirtilen rengi uygula
        End With
    Next i
    Application.DisplayAlerts = True
End Sub
 

Ekli dosyalar

çözümü inceliyorum sayın Next Level
sizin çözümünüzde listedeki tüm tarihleri alarak çözüm yapıyo. emeğinize sağlık. acaba belirli 2 tarih arasında bu çözümü güncelleyebilir misiniz.

ayrıca ben kareler arasını 10 metre yaptım. sizin makro çözümünüz 1 metreye göre olabilir mi
 
bu eklediğim hali ile olan yani tabakaların başına ve sonunu düşey yönde hanki km aralıklarında olduklarıda yazılabilir mi
mavi dolgu ile belirttiğim yerlere

Sayın NextLevel sizden gelen ilk çözüm doğrultusunda bazı eklemelerde aklıma geliyo ve soruma yeni yeni eklemeler yapabiliyorum. umarım çözümleride bulunur.
benim projemde yolum 30 km olacak her kare arası 10 metre alsam 3000 sütunluk bir karelajla sizden gelen çözümleri dönüştürmeyi planlıyorum. ancak her kareyi 100 metre olarak belirlemem gerekirse çözümler olabilir mi diye merak ediyorum.
 

Ekli dosyalar

C#: 
Private Sub CommandButton1_Click()
    Application.DisplayAlerts = False
    '......
    'Öncelikle mevcut grafik alanını temizleyelim
    ilk = 10
    son = WorksheetFunction.CountA(Rows("5")) - 1
    SonSat = Range("I" & Application.Rows.Count).End(xlUp).Row
    With Range(Cells(6, ilk), Cells(SonSat, son))
        .UnMerge
        .ClearContents
        .Borders.LineStyle = xlNone
        .Interior.Color = xlNone
    End With
    '.....
    'Listeye göre yeniden grafik alanını düzenleyelim
    For i = 7 To Range("C7").End(xlDown).Row
        Satır = WorksheetFunction.Match(Cells(i, 4), Range("I:I"), 0)
        ilk = Range("E" & i) / 10
        If ilk = 0 Then
            ilk = ilk + 10
        Else
            ilk = ilk + 11
        End If
        son = Range("F" & i) / 10 + 10
        Cells(Satır, ilk) = Cells(i, 7) & " / (" & Cells(i, 3) & ")"
        Cells(Satır - 5, ilk) = Format(Range("E" & i), "0+000.000")
        Cells(Satır - 5, son) = Format(Range("F" & i), "0+000.000")
        Range("J5").Copy
        Cells(Satır - 5, ilk).PasteSpecial (xlFormats)
        Cells(Satır - 5, son).PasteSpecial (xlFormats)
        Cells(Satır - 5, ilk).Interior.ColorIndex = 48
        Cells(Satır - 5, son).Interior.ColorIndex = 48
        Range(Cells(Satır - 5, ilk), Cells(Satır - 1, ilk)).Merge
        Range(Cells(Satır - 5, son), Cells(Satır - 1, son)).Merge
        With Range(Cells(Satır, ilk), Cells(Satır, son))
            .HorizontalAlignment = xlCenter
            .Merge
            .BorderAround xlContinuous, xlThin
            .Interior.Color = Range("D" & i).Interior.Color ' Listede belirtilen rengi uygula
        End With
    Next i
    Application.DisplayAlerts = True
End Sub
 

Ekli dosyalar

sayın nextlevel çözümlü dosya ekleyebilirmisiniz
benim en son eklediğim dosyada kodu değiştim ama çalıştıramadım
 
sayın hocam
çözümü belirli 2 tarih arasında olarak süzebilir miyiz.
başlangıç tarihi = 01.12.2020
bitiş tarihi = 06.12.2020 olacak şekilde aynı çözümü yapabilir miyiz.
 
G2 ve G3 hücrelerine ilk ve son tatihleri girebilirsin
C#: 
Private Sub CommandButton1_Click()
    Application.DisplayAlerts = False
    '......
    'Öncelikle mevcut grafik alanını temizleyelim
    ilk = 10
    son = WorksheetFunction.CountA(Rows("5")) - 1
    SonSat = Range("I" & Application.Rows.Count).End(xlUp).Row
    With Range(Cells(6, ilk), Cells(SonSat, son))
        .UnMerge
        .ClearContents
        .Borders.LineStyle = xlNone
        .Interior.Color = xlNone
    End With
    '.....
    'Listeye göre yeniden grafik alanını düzenleyelim
    For i = 7 To Range("C7").End(xlDown).Row
        If Range("C" & i) < [G2] Or Range("C" & i) > [G3] Then GoTo ATLA
        Satır = WorksheetFunction.Match(Cells(i, 4), Range("I:I"), 0)
        ilk = Range("E" & i) / 10
        If ilk = 0 Then
            ilk = ilk + 10
        Else
            ilk = ilk + 11
        End If
        son = Range("F" & i) / 10 + 10
        Cells(Satır, ilk) = Cells(i, 7) & " / (" & Cells(i, 3) & ")"
        Cells(Satır - 5, ilk) = Format(Range("E" & i), "0+000.000")
        Cells(Satır - 5, son) = Format(Range("F" & i), "0+000.000")
        Range("J5").Copy
        Cells(Satır - 5, ilk).PasteSpecial (xlFormats)
        Cells(Satır - 5, son).PasteSpecial (xlFormats)
        Cells(Satır - 5, ilk).Interior.ColorIndex = 48
        Cells(Satır - 5, son).Interior.ColorIndex = 48
        Range(Cells(Satır - 5, ilk), Cells(Satır - 1, ilk)).Merge
        Range(Cells(Satır - 5, son), Cells(Satır - 1, son)).Merge
        With Range(Cells(Satır, ilk), Cells(Satır, son))
            .HorizontalAlignment = xlCenter
            .Merge
            .BorderAround xlContinuous, xlThin
            .Interior.Color = Range("D" & i).Interior.Color ' Listede belirtilen rengi uygula
        End With
ATLA:
    Next i
    Application.DisplayAlerts = True
End Sub
 
uyguladım sonuç tamam hocam
bu konuyla ilgili ilk etapta sorduklarımın cevabını aldım çok teşekkür ederim
ama ileriki zamanda aynı konu ile ilgili eklemelerim olacak sayın NextLevel. mesela bölünmüş yollarda yolun sol kesimi sağ kesimi gibi yani verdiğim tablo verilerine birkaç sütun ekleyerek en nihai haline dönüştürüp sorumu güncelleyecem yardımlarınızı bekliyorum inşallah
 
İnşallah.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst