kod kısaltmak mümkün mü ?

ankara34 · 3 Haziran 2024

selamlar arkadaşlar

alttaki kodu çalıştırdığımda çok uzun sürüyor
bunu kısaltmak mümkün mü ?

Kod:

Sub bakkal()
    Dim i As Long
    Dim zonsatir As Long
    Dim ws As Worksheet

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set ws = ThisWorkbook.Sheets("ZKPY")
    zonsatir = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    
    For i = 1 To zonsatir
        If ws.Cells(i, 6) = 1 Then
            Call ALIS
        Else
            Call SATIS
        End If
    Next i
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub ALIS()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    
    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    nextRow = 1
    currentIsim = ws.Cells(1, "D").Value
    toplam = 0
    
    For i = 1 To lastRow
        isim = ws.Cells(i, "D").Value
        sayi = CDbl(ws.Cells(i, "C").Value)
        
        If isim <> currentIsim Then
            ws.Cells(nextRow, "K").Value = currentIsim
            ws.Cells(nextRow, "L").Value = toplam
            ws.Cells(nextRow, "J").Value = ws.Cells(i - 1, "B").Value
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
        
        If i = lastRow Then
            ws.Cells(nextRow, "K").Value = currentIsim
            ws.Cells(nextRow, "L").Value = toplam
            ws.Cells(nextRow, "J").Value = ws.Cells(i, "B").Value
        End If
        
        ws.Cells(i, "J").NumberFormat = "hh:mm:ss"
    Next i
End Sub

Sub SATIS()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    
    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    nextRow = 1
    currentIsim = ws.Cells(1, "E").Value
    toplam = 0
    
    For i = 1 To lastRow
        isim = ws.Cells(i, "E").Value
        sayi = CDbl(ws.Cells(i, "C").Value)
        
        If isim <> currentIsim Then
            ws.Cells(nextRow, "P").Value = currentIsim
            ws.Cells(nextRow, "Q").Value = toplam
            ws.Cells(nextRow, "O").Value = ws.Cells(i - 1, "B").Value
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
        
        If i = lastRow Then
            ws.Cells(nextRow, "P").Value = currentIsim
            ws.Cells(nextRow, "Q").Value = toplam
            ws.Cells(nextRow, "O").Value = ws.Cells(i, "B").Value
        End If
        
        ws.Cells(i, "O").NumberFormat = "hh:mm:ss"
    Next i
End Sub

maliex · 4 Haziran 2024

Merhabalar kodlar hücre üzerinde çalışıyor, bunun yerine diziye alıp döngüye sokmakta fayda var

cems · 4 Haziran 2024

.....

HücrelereFısıldayanAdam · 4 Haziran 2024

Deneyiniz:

Kod:

Sub bakkal()
    Dim i As Long
    Dim zonsatir As Long
    Dim ws As Worksheet
    Dim MY_DATA As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    zonsatir = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    MY_DATA = ws.Range("A1:F" & zonsatir).Value ' Verileri diziye aktar

    For i = 1 To zonsatir
        If MY_DATA(i, 6) = 1 Then
            Call ALIS(MY_DATA)
        Else
            Call SATIS(MY_DATA)
        End If
    Next i
    
    ws.Range("A1:F" & zonsatir).Value = MY_DATA ' İşlenmiş verileri hücrelere geri aktar

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub ALIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 4)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 4)
        sayi = CDbl(MY_DATA(i, 3))
        
        If isim <> currentIsim Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
        
        If i = lastRow Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i, 2)
        End If
        
        MY_DATA(i, 10) = Format(MY_DATA(i, 2), "hh:mm:ss")
    Next i

    ws.Range("J1:L" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub SATIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 5)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 5)
        sayi = CDbl(MY_DATA(i, 3))
        
        If isim <> currentIsim Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
        
        If i = lastRow Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i, 2)
        End If
        
        MY_DATA(i, 15) = Format(MY_DATA(i, 2), "hh:mm:ss")
    Next i

    ws.Range("O1:Q" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

ankara34 · 4 Haziran 2024

HücrelereFısıldayanAdam' Alıntı:

Deneyiniz:

Kod:

Sub bakkal()
    Dim i As Long
    Dim zonsatir As Long
    Dim ws As Worksheet
    Dim MY_DATA As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    zonsatir = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    MY_DATA = ws.Range("A1:F" & zonsatir).Value ' Verileri diziye aktar

    For i = 1 To zonsatir
        If MY_DATA(i, 6) = 1 Then
            Call ALIS(MY_DATA)
        Else
            Call SATIS(MY_DATA)
        End If
    Next i
   
    ws.Range("A1:F" & zonsatir).Value = MY_DATA ' İşlenmiş verileri hücrelere geri aktar

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub ALIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 4)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 4)
        sayi = CDbl(MY_DATA(i, 3))
       
        If isim <> currentIsim Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
       
        If i = lastRow Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i, 2)
        End If
       
        MY_DATA(i, 10) = Format(MY_DATA(i, 2), "hh:mm:ss")
    Next i

    ws.Range("J1:L" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub SATIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 5)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 5)
        sayi = CDbl(MY_DATA(i, 3))
       
        If isim <> currentIsim Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
       
        If i = lastRow Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i, 2)
        End If
       
        MY_DATA(i, 15) = Format(MY_DATA(i, 2), "hh:mm:ss")
    Next i

    ws.Range("O1:Q" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Hocam alttaki hatayı verdi,
nerden kaynaklanıyor olabilir ?

FRM.png dosyasını indir - download

FRM.png dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

Muzaffer Ali · 4 Haziran 2024

Bu kod ile ne yapmak istediğinizi bir örnek dosya ile açıklarsanız çok çok daha hızlı çalışan bir kod yazılabilir.
Örnek dosyayı dosya.tc gibi bir paylaşım sitesine ekleyebilirsiniz.,

HücrelereFısıldayanAdam · 5 Haziran 2024

Örnek veri göndermeniz daha mantıklı.

Kod:

Sub BAKKAL()
    Dim i As Long
    Dim zonsatir As Long
    Dim ws As Worksheet
    Dim MY_DATA As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    zonsatir = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    MY_DATA = ws.Range("A1:F" & zonsatir).Value

    For i = 1 To zonsatir
        If MY_DATA(i, 6) = 1 Then
            Call ALIS(MY_DATA)
        Else
            Call SATIS(MY_DATA)
        End If
    Next i
   
    ws.Range("A1:F" & zonsatir).Value = MY_DATA
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub ALIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 4)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 4)
        sayi = CDbl(MY_DATA(i, 3))
       
        If isim <> currentIsim Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
       
        If i = lastRow Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i, 2)
        End If
    Next i

    ws.Range("J1:L" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub SATIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 5)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 5)
        sayi = CDbl(MY_DATA(i, 3))
       
        If isim <> currentIsim Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
       
        If i = lastRow Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i, 2)
        End If
    Next i

    ws.Range("O1:Q" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

ankara34 · 6 Haziran 2024

Muzaffer Ali' Alıntı:
Bu kod ile ne yapmak istediğinizi bir örnek dosya ile açıklarsanız çok çok daha hızlı çalışan bir kod yazılabilir.
Örnek dosyayı dosya.tc gibi bir paylaşım sitesine ekleyebilirsiniz.,

Muzaffer Ali Bey , dediğiniz gibi örnek dosyamı dosya.tc ye yükledim.
yardımcı olabilirseniz sevinirim..

FORUM.xlsm dosyasını indir - download

FORUM.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

ankara34 · 6 Haziran 2024

HücrelereFısıldayanAdam' Alıntı:

Örnek veri göndermeniz daha mantıklı.

Kod:

Sub BAKKAL()
    Dim i As Long
    Dim zonsatir As Long
    Dim ws As Worksheet
    Dim MY_DATA As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    zonsatir = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    MY_DATA = ws.Range("A1:F" & zonsatir).Value

    For i = 1 To zonsatir
        If MY_DATA(i, 6) = 1 Then
            Call ALIS(MY_DATA)
        Else
            Call SATIS(MY_DATA)
        End If
    Next i
  
    ws.Range("A1:F" & zonsatir).Value = MY_DATA
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub ALIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 4)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 4)
        sayi = CDbl(MY_DATA(i, 3))
      
        If isim <> currentIsim Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
      
        If i = lastRow Then
            resultArray(nextRow, 11) = currentIsim
            resultArray(nextRow, 12) = toplam
            resultArray(nextRow, 10) = MY_DATA(i, 2)
        End If
    Next i

    ws.Range("J1:L" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub SATIS(MY_DATA As Variant)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentIsim As String
    Dim toplam As Double
    Dim nextRow As Long
    Dim isim As String
    Dim sayi As Double
    Dim resultArray As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set ws = ThisWorkbook.Sheets("ZKPY")
    lastRow = UBound(MY_DATA)
    nextRow = 1
    currentIsim = MY_DATA(1, 5)
    toplam = 0
    ReDim resultArray(1 To lastRow, 1 To 12)

    For i = 1 To lastRow
        isim = MY_DATA(i, 5)
        sayi = CDbl(MY_DATA(i, 3))
      
        If isim <> currentIsim Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i - 1, 2)
            nextRow = nextRow + 1
            currentIsim = isim
            toplam = sayi
        Else
            toplam = toplam + sayi
        End If
      
        If i = lastRow Then
            resultArray(nextRow, 16) = currentIsim
            resultArray(nextRow, 17) = toplam
            resultArray(nextRow, 15) = MY_DATA(i, 2)
        End If
    Next i

    ws.Range("O1:Q" & nextRow).Value = resultArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sayın HücrelereFısıldayanAdam , dediğiniz gibi örnek dosyamı dosya.tc ye yükledim.
yardımcı olabilirseniz sevinirim..

FORUM.xlsm dosyasını indir - download

FORUM.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

dost · 6 Haziran 2024

Merhaba,

Sorunuzu anladığım kadarı ile...
Aşağıdaki kodu deneyiniz.

C++:

Sub Test()
    Dim adoCN As Object, RS As Object
    Dim strSQL As String
    Dim lRow As Integer
  
    Application.ScreenUpdating = False
  
    lRow = Sheets("MARKET").Cells(Sheets("MARKET").Rows.Count, "G").End(xlUp).Row
    Sheets("MARKET").Range("G2:I" & WorksheetFunction.Max(lRow, 2)).ClearContents
    
    lRow = Sheets("MARKET").Cells(Sheets("MARKET").Rows.Count, "K").End(xlUp).Row
    Sheets("MARKET").Range("K2:M" & WorksheetFunction.Max(lRow, 2)).ClearContents
    
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;"""
            
            
    strSQL = "SELECT  SUM([KG]), [ALAN], [TKP KOD]  " & _
             "FROM [MARKET$] " & _
             "WHERE [TKP KOD] = 1 " & _
             "GROUP BY [ALAN], [TKP KOD] " & _
             "HAVING COUNT([TKP KOD]) > 1 "
  
    Set RS = adoCN.Execute(strSQL)
    Sheets("MARKET").Range("G1").Resize(1, 3) = Array("KG", "ALAN", "TKP KOD")
    Sheets("MARKET").Range("G2").CopyFromRecordset RS
    
    
    strSQL = "SELECT  SUM([KG]), [SATAN], [TKP KOD]  " & _
             "FROM [MARKET$] " & _
             "WHERE [TKP KOD] = 2 " & _
             "GROUP BY [SATAN], [TKP KOD] " & _
             "HAVING COUNT([TKP KOD]) > 1 "
  
    Set RS = adoCN.Execute(strSQL)
    Sheets("MARKET").Range("K1").Resize(1, 3) = Array("KG", "SATAN", "TKP KOD")
    Sheets("MARKET").Range("K2").CopyFromRecordset RS
  
    RS.Close:    adoCN.Close
    Set RS = Nothing:    Set adoCN = Nothing
  
    MsgBox "İşlem Tamamlandı"
  
    Application.ScreenUpdating = True
  
End Sub

ankara34 · 6 Haziran 2024

dost' Alıntı:

Merhaba,

Sorunuzu anladığım kadarı ile...
Aşağıdaki kodu deneyiniz.

C++:

Sub Test()
    Dim adoCN As Object, RS As Object
    Dim strSQL As String
    Dim lRow As Integer
 
    Application.ScreenUpdating = False
 
    lRow = Sheets("MARKET").Cells(Sheets("MARKET").Rows.Count, "G").End(xlUp).Row
    Sheets("MARKET").Range("G2:I" & WorksheetFunction.Max(lRow, 2)).ClearContents
   
    lRow = Sheets("MARKET").Cells(Sheets("MARKET").Rows.Count, "K").End(xlUp).Row
    Sheets("MARKET").Range("K2:M" & WorksheetFunction.Max(lRow, 2)).ClearContents
   
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;"""
           
           
    strSQL = "SELECT  SUM([KG]), [ALAN], [TKP KOD]  " & _
             "FROM [MARKET$] " & _
             "WHERE [TKP KOD] = 1 " & _
             "GROUP BY [ALAN], [TKP KOD] " & _
             "HAVING COUNT([TKP KOD]) > 1 "
 
    Set RS = adoCN.Execute(strSQL)
    Sheets("MARKET").Range("G1").Resize(1, 3) = Array("KG", "ALAN", "TKP KOD")
    Sheets("MARKET").Range("G2").CopyFromRecordset RS
   
   
    strSQL = "SELECT  SUM([KG]), [SATAN], [TKP KOD]  " & _
             "FROM [MARKET$] " & _
             "WHERE [TKP KOD] = 2 " & _
             "GROUP BY [SATAN], [TKP KOD] " & _
             "HAVING COUNT([TKP KOD]) > 1 "
 
    Set RS = adoCN.Execute(strSQL)
    Sheets("MARKET").Range("K1").Resize(1, 3) = Array("KG", "SATAN", "TKP KOD")
    Sheets("MARKET").Range("K2").CopyFromRecordset RS
 
    RS.Close:    adoCN.Close
    Set RS = Nothing:    Set adoCN = Nothing
 
    MsgBox "İşlem Tamamlandı"
 
    Application.ScreenUpdating = True
 
End Sub

ilginiz için teşekkür ederim,
sizin kod sonuçları ile benimkiler farklı çıkıyor

FRMM.png dosyasını indir - download

FRMM.png dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

dost · 6 Haziran 2024

Merhaba,

1- SATAN'da TKP KOD=2 olan SEHER tek satırda geçiyor. Sonuçta onu niye istiyorsunuz?

2- SATAN'da TKP KOD=2 olan RÜMEYSA üç satır var. Sonuçta 2 satır toplamışsınız ve tek satır olarak göstermişsiniz, ayrıca diğeri 1 satırda, neden?

3- SATAN'da TKP KOD=2 olan HALİL üç satır var. Sonuçta 2 satır toplamışsınız ve tek satır olarak göstermişsiniz, ayrıca diğeri 1 satırda, neden?

Ziynettin · 6 Haziran 2024

Bu kodu deneyin.

Kod:

Sub test()
son = Range("A" & Rows.Count).End(3).Row
If son < 2 Then Exit Sub
a = Range("A1:D" & son).Value
Set dc = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 2)
ReDim v1(1 To UBound(a), 1 To 3)
ReDim v2(1 To UBound(a), 1 To 3)
s = 0
n = 0
For i = 2 To UBound(a)
    say = say + 1
    If i = 1 Then
        b(say, 1) = s
        b(say, 2) = n
    Else
        If a(i - 1, 2) & a(i - 1, 4) <> a(i, 2) & a(i, 4) Then
            s = s + 1
            b(say, 1) = s
        Else
            b(say, 1) = s
            s = s + 1
        End If
        
        If a(i - 1, 3) & a(i - 1, 4) <> a(i, 3) & a(i, 4) Then
            n = n + 1
            b(say, 2) = n
        Else
            b(say, 2) = n
            n = n + 1
        End If
    End If
    If a(i, 4) = 1 Then
        krt1 = a(i, 2) & "|" & b(say, 1)
        If Not dc.exists(krt1) Then
            dc(krt1) = dc.Count + 1
            p = dc.Count
        Else
            p = dc(krt1)
        End If
        v1(p, 1) = v1(p, 1) + a(i, 1)
        v1(p, 2) = a(i, 2)
        v1(p, 3) = a(i, 4)
    End If
    If a(i, 4) = 2 Then
        krt2 = a(i, 3) & "|" & b(say, 2)
        If Not ds.exists(krt2) Then
            ds(krt2) = ds.Count + 1
            r = ds.Count
        Else
            r = ds(krt2)
        End If
        v2(r, 1) = v2(r, 1) + a(i, 1)
        v2(r, 2) = a(i, 3)
        v2(r, 3) = a(i, 4)
    End If
Next i

Range("G2:I" & Rows.Count).ClearContents
Range("G2:I" & Rows.Count).ClearFormats
If dc.Count > 0 Then
    [G2].Resize(dc.Count, 3) = v1
    [G2].Resize(dc.Count, 3).Borders.Color = rgbSilver
End If

Range("K2:M" & Rows.Count).ClearContents
Range("K2:M" & Rows.Count).ClearFormats
If ds.Count > 0 Then
    [K2].Resize(ds.Count, 3) = v2
    [K2].Resize(ds.Count, 3).Borders.Color = rgbSilver
End If
MsgBox "İşlem Bitti.", vbInformation
End Sub

kod kısaltmak mümkün mü ?

ankara34

maliex

cems

HücrelereFısıldayanAdam

ankara34

FRM.png dosyasını indir - download

Muzaffer Ali

Destek Ekibi

HücrelereFısıldayanAdam

ankara34

FORUM.xlsm dosyasını indir - download

ankara34

FORUM.xlsm dosyasını indir - download

dost

ankara34

FRMM.png dosyasını indir - download

dost

Ziynettin

Destek Ekibi