Benzin ve motorin

yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
Arkadaşlar ekteki tabloya göre işlemlerin yapılması. şimdiden teşekkür ederim.
 

Ekli dosyalar

yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
Arkadaşlar yardımlarınızı bekliyorum
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Sorunun çözümü için aşağıdaki makroyu başlangıç olarak hazırlamıştım ancak maalesef sql sorgu kısmında hata (Sorgu ifadesi içindeli sayıda sözdizimi hatası) verdiği için işlem tamamlanmıyor. Tecrübeli arkadaşlarım hatamı düzeltirlerse epey yol almış oalcağız:

PHP: 
Sub rapor()
    Set s1 = Sheets("Rapor")
    Set s2 = Sheets("LİSTE BURAYA GELSİN")
    son = s1.Cells(Rows.Count, "A").End(3).Row
    eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "D").End(3).Row)
    s1.Activate
    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("C2:C" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    s1.Sort.SortFields.Add Key:=Range("B2:B" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add Key:=Range("A2:A" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Rapor").Sort
        .SetRange Range("A1:E" & son)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For j = 2 To son
        s1.Cells(j, "B") = WorksheetFunction.RoundDown(s1.Cells(j, "B"), 0)
    Next
    s2.Activate
    s2.Range("A2:E" & eski).ClearContents
    For i = 2 To son
        If WorksheetFunction.CountIfs(s1.Range("C1:C" & i), s1.Cells(i, "C"), s1.Range("B1:B" & i), s1.Cells(i, "B")) = 1 Then
            Set con = VBA.CreateObject("adodb.Connection")
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
            sorgu = "select [Plaka/KartNo],[İşlemTarihi],[Ürün],[Miktar(LT)],[İstasyon]" & _
              "from[Rapor$] where [Ürün] = '" & s1.Cells(i, "C") & "' and [İşlemTarihi] = " & s1.Cells(i, "B")
            Set rs = con.Execute(sorgu)
            yeni = s2.Cells(Rows.Count, "D").End(3).Row + 1
            s2.Range("A" & yeni).CopyFromRecordset rs
            adet = WorksheetFunction.CountIfs(s1.Range("C1:C" & son), s1.Cells(i, "C"), s1.Range("B1:B" & son), s1.Cells(i, "B"))
            s2.Cells(yeni + adet - 1, "D") = WorksheetFunction.SumIfs(s1.Range("D1:D" & son), s1.Range("C1:C" & son), s1.Cells(i, "C"), s1.Range("B1:B" & son), s1.Cells(i, "B"))
        End If
    Next
End Sub
 
yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
Emek yapmışsınız teşekkür ederim. Şimdi makro konusunda acemiyim yukarıdaki bilgileri nereye yapıştırmam lazım. İnşaallah diğer arkadaşlar yardımcı olur.
 
yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
Arkadaşlar bir çözüm bulamadık
 
mc_exrem

mc_exrem

Katılım
25 Mayıs 2010
Mesajlar
480
Excel Vers. ve Dili
Office 2019
64bit
Tr
Win 10
Altın Üyelik Bitiş Tarihi
12-07-2024
YUSUF44' Alıntı:
Sorunun çözümü için aşağıdaki makroyu başlangıç olarak hazırlamıştım ancak maalesef sql sorgu kısmında hata (Sorgu ifadesi içindeli sayıda sözdizimi hatası) verdiği için işlem tamamlanmıyor. Tecrübeli arkadaşlarım hatamı düzeltirlerse epey yol almış oalcağız:

PHP: 
Sub rapor()
    Set s1 = Sheets("Rapor")
    Set s2 = Sheets("LİSTE BURAYA GELSİN")
    son = s1.Cells(Rows.Count, "A").End(3).Row
    eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "D").End(3).Row)
    s1.Activate
    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("C2:C" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    s1.Sort.SortFields.Add Key:=Range("B2:B" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add Key:=Range("A2:A" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Rapor").Sort
        .SetRange Range("A1:E" & son)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For j = 2 To son
        s1.Cells(j, "B") = WorksheetFunction.RoundDown(s1.Cells(j, "B"), 0)
    Next
    s2.Activate
    s2.Range("A2:E" & eski).ClearContents
    For i = 2 To son
        If WorksheetFunction.CountIfs(s1.Range("C1:C" & i), s1.Cells(i, "C"), s1.Range("B1:B" & i), s1.Cells(i, "B")) = 1 Then
            Set con = VBA.CreateObject("adodb.Connection")
            con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
            sorgu = "select [Plaka/KartNo],[İşlemTarihi],[Ürün],[Miktar(LT)],[İstasyon]" & _
              "from[Rapor$] where [Ürün] = '" & s1.Cells(i, "C") & "' and [İşlemTarihi] = " & s1.Cells(i, "B")
            Set rs = con.Execute(sorgu)
            yeni = s2.Cells(Rows.Count, "D").End(3).Row + 1
            s2.Range("A" & yeni).CopyFromRecordset rs
            adet = WorksheetFunction.CountIfs(s1.Range("C1:C" & son), s1.Cells(i, "C"), s1.Range("B1:B" & son), s1.Cells(i, "B"))
            s2.Cells(yeni + adet - 1, "D") = WorksheetFunction.SumIfs(s1.Range("D1:D" & son), s1.Range("C1:C" & son), s1.Cells(i, "C"), s1.Range("B1:B" & son), s1.Cells(i, "B"))
        End If
    Next
End Sub
Genişletmek için tıkla ...
Ekledim ama hata verdi!
214702
 
yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
yani olacakmı?
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
yuzun23' Alıntı:
yani olacakmı?
Genişletmek için tıkla ...
Aşağıdaki makroyu deneyin:

PHP: 
Sub rapor()
    Application.ScreenUpdating = False
    Set s1 = Sheets("Rapor")
    Set s2 = Sheets("LİSTE BURAYA GELSİN")
    son = s1.Cells(Rows.Count, "A").End(3).Row
    eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "D").End(3).Row)
    s1.Activate
    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("C2:C" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    s1.Sort.SortFields.Add Key:=Range("B2:B" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add Key:=Range("A2:A" & son), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Rapor").Sort
        .SetRange Range("A1:E" & son)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For j = 2 To son
        s1.Cells(j, "B") = WorksheetFunction.RoundDown(s1.Cells(j, "B"), 0)
    Next
    s2.Activate
    s2.Range("A2:E" & eski).Clear
    s1.Range("A2:E" & son).Copy s2.[A2]
    
    For i = son To 2 Step -1
        If s2.Cells(i, "C") <> s2.Cells(i + 1, "C") And s2.Cells(i, "C") <> s2.Cells(i + 1, "B") Then
            s2.Range("A" & i + 1 & ":E" & i + 2).Insert Shift:=xlDown
            s2.Cells(i + 1, "D") = WorksheetFunction.SumIfs(s1.Range("D1:D" & son), s1.Range("C1:C" & son), s2.Cells(i, "C"), _
                                    s1.Range("B1:B" & son), s2.Cells(i, "B"))
            s2.Cells(i + 2, "C") = "TOPLAM"
            s2.Cells(i + 2, "D") = WorksheetFunction.SumIf(s1.Range("C1:C" & son), s2.Cells(i, "C"), s1.Range("D1:D" & son))
            With s2.Range("C" & i + 2 & ":D" & i + 2)
                .Font.Bold = True
                .Font.Color = vbRed
            End With
            s2.Cells(i + 1, "D").Font.Bold = True
        ElseIf s2.Cells(i, "C") = s2.Cells(i + 1, "C") And s2.Cells(i, "B") <> s2.Cells(i + 1, "B") Then
            s2.Range("A" & i + 1 & ":E" & i + 1).Insert Shift:=xlDown
            s2.Cells(i + 1, "D") = WorksheetFunction.SumIfs(s1.Range("D1:D" & son), s1.Range("C1:C" & son), s2.Cells(i, "C"), _
                                    s1.Range("B1:B" & son), s2.Cells(i, "B"))
            s2.Cells(i + 1, "D").Font.Bold = True
        End If
    Next
    enson = s2.Cells(Rows.Count, "D").End(3).Row
    s2.Range("A2:E" & enson).Borders.LineStyle = 1
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı"
End Sub
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Son verdiğim çözüm örnek dosyaya göre iş görüyor. Ancak ilk kullanmak istediğim sql metoduna göre uzun sürüyor. Verilerinizin çokluğuna göre işlemin tamamlanması uzun sürebilir.
 
yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
YUSUF KARDEŞ, MAKRO ACEMİSİYİM BU KODU BELGEYE NEREYE ATMAM GEREKİYOR. YARDIMCI OLURMUSUNUZ VEYA SİZ TAMANIZ MÜMKÜNMÜ? ALLAH'A AMANET OLUN
 
yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
YUSUF KARDEŞ ALLAHA AMANET OLUN ELLERİNİZE SAĞLIK HALLETTİM
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod: 
Sub test()
   
    Set s1 = Sheets("Rapor")
    Set s2 = Sheets("LİSTE BURAYA GELSİN")
    son = s1.Cells(Rows.Count, "A").End(3).Row
   
    With s2.Range("A2:E" & Rows.Count)
        .ClearContents
        .Font.Color = 0
        .Font.Bold = False
    End With

    urun = "KBN95 V/MAX 95"
    sat = 2
    GoSub calistir
   
    urun = "Motorin MED"
    GoSub calistir

    Exit Sub

calistir:
    tar = Format(s1.[b2], "DDMMYY")
    urunTop = 0
    gunTop = 0

    For i = 2 To son + 1
        If s1.Cells(i, "C") = urun Or i = son + 1 Then
            If tar = Format(s1.Cells(i, "B"), "DDMMYY") Then
                gunTop = gunTop + s1.Cells(i, "D")
                urunTop = urunTop + s1.Cells(i, "D")
                s2.Cells(sat, 1).Resize(, 5).Value = s1.Cells(i, 1).Resize(, 5).Value
            Else
                tar = Format(s1.Cells(i, "B"), "DDMMYY")
                If gunTop > 0 Then
                    s2.Cells(sat, "D").Value = gunTop
                    s2.Cells(sat, "D").Font.Bold = True
                    gunTop = 0
                    i = i - 1
                End If
            End If
            sat = sat + 1
        End If
    Next i
   
    sat = sat - 1
    s2.Cells(sat, "C").Value = "TOPLAM"
    s2.Cells(sat, "D").Value = urunTop
    s2.Cells(sat, "C").Resize(, 2).Font.Color = vbRed
    s2.Cells(sat, "C").Resize(, 2).Font.Bold = True
    urunTop = 0
    sat = sat + 3
    Return
End Sub
 

Ekli dosyalar

yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
veyselemre' Alıntı:
Kod: 
Sub test()
  
    Set s1 = Sheets("Rapor")
    Set s2 = Sheets("LİSTE BURAYA GELSİN")
    son = s1.Cells(Rows.Count, "A").End(3).Row
  
    With s2.Range("A2:E" & Rows.Count)
        .ClearContents
        .Font.Color = 0
        .Font.Bold = False
    End With

    urun = "KBN95 V/MAX 95"
    sat = 2
    GoSub calistir
  
    urun = "Motorin MED"
    GoSub calistir

    Exit Sub

calistir:
    tar = Format(s1.[b2], "DDMMYY")
    urunTop = 0
    gunTop = 0

    For i = 2 To son + 1
        If s1.Cells(i, "C") = urun Or i = son + 1 Then
            If tar = Format(s1.Cells(i, "B"), "DDMMYY") Then
                gunTop = gunTop + s1.Cells(i, "D")
                urunTop = urunTop + s1.Cells(i, "D")
                s2.Cells(sat, 1).Resize(, 5).Value = s1.Cells(i, 1).Resize(, 5).Value
            Else
                tar = Format(s1.Cells(i, "B"), "DDMMYY")
                If gunTop > 0 Then
                    s2.Cells(sat, "D").Value = gunTop
                    s2.Cells(sat, "D").Font.Bold = True
                    gunTop = 0
                    i = i - 1
                End If
            End If
            sat = sat + 1
        End If
    Next i
  
    sat = sat - 1
    s2.Cells(sat, "C").Value = "TOPLAM"
    s2.Cells(sat, "D").Value = urunTop
    s2.Cells(sat, "C").Resize(, 2).Font.Color = vbRed
    s2.Cells(sat, "C").Resize(, 2).Font.Bold = True
    urunTop = 0
    sat = sat + 3
    Return
End Sub
Genişletmek için tıkla ...

TEŞEKKÜR EDERİM. ALLAH RAZI OLSUN
 
yuzun23

yuzun23

Altın Üye
Katılım
11 Mayıs 2006
Mesajlar
657
Excel Vers. ve Dili
Ofis 2016 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
17-01-2026
yuzun23' Alıntı:
TEŞEKKÜR EDERİM. ALLAH RAZI OLSUN
Genişletmek için tıkla ...

VEYSEL KARDEŞİM, SONUÇLAR TUTMUYOR. ÖRNEK; AYNI GÜN 33 LT VARKEN BİR TANESİNİ VERİYOR. BİRDE OLMAMASI GEREKEN TARİHLERİ VERMEKTE TEŞEKKÜR EDERİM.
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
yuzun23' Alıntı:
VEYSEL KARDEŞİM, SONUÇLAR TUTMUYOR. ÖRNEK; AYNI GÜN 33 LT VARKEN BİR TANESİNİ VERİYOR. BİRDE OLMAMASI GEREKEN TARİHLERİ VERMEKTE TEŞEKKÜR EDERİM.
Genişletmek için tıkla ...
Hata veren örnek ekleyin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst