Benzin ve motorin

yuzun23 · 26 Şubat 2020

Arkadaşlar ekteki tabloya göre işlemlerin yapılması. şimdiden teşekkür ederim.

yuzun23 · 26 Şubat 2020

Arkadaşlar yardımlarınızı bekliyorum

YUSUF44 · 26 Şubat 2020

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 · 26 Şubat 2020

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 · 27 Şubat 2020

Arkadaşlar bir çözüm bulamadık

mc_exrem · 27 Şubat 2020

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

Ekledim ama hata verdi!

yuzun23 · 27 Şubat 2020

yani olacakmı?

YUSUF44 · 27 Şubat 2020

mc_exrem' Alıntı:
Ekledim ama hata verdi!

Ben de hata verdiğini belirtmiştim zaten. Nedenini bulamadığımdan çözümü ilerletemedim maalesef.

YUSUF44 · 27 Şubat 2020

yuzun23' Alıntı:
yani olacakmı?

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 · 27 Şubat 2020

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 · 27 Şubat 2020

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 · 27 Şubat 2020

YUSUF KARDEŞ ALLAHA AMANET OLUN ELLERİNİZE SAĞLIK HALLETTİM

veyselemre · 27 Şubat 2020

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

yuzun23 · 27 Şubat 2020

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

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

yuzun23 · 28 Şubat 2020

yuzun23' Alıntı:
TEŞEKKÜR EDERİM. ALLAH RAZI OLSUN

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 · 28 Şubat 2020

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.

Hata veren örnek ekleyin.

Benzin ve motorin

yuzun23

Ekli dosyalar

yuzun23

YUSUF44

Destek Ekibi

yuzun23

yuzun23

mc_exrem

yuzun23

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

yuzun23

yuzun23

veyselemre

Özel Üye

Ekli dosyalar

yuzun23

yuzun23

veyselemre

Özel Üye