Toplam Alma

[hbgunay]

Merhaba bir konuda yardımlarınızı bekliyorum. Şirketimizde logo kullanıyoruz. Bu programdan gelen siparişleri excele atarak bir takım düzenlemeler yapıyorum. Bu işlemde bayağı bir zaman alıyor. Bunu daha seri yapabilirmiyim diye sizlere danışmak istedim. Sorunumu örnek dosyada paylaşmak istedim. Gelen siparişleri excele attığımda sayfa 1 deki gibi oluyor. Bende onları sayfa 2 deki hale getiriyorum. Bütün ürünlerin tek tek toplamlarını alıyorum. Bu da satır ve ürün sayısı epeyce fazla olduğu için bayağı bir vaktimi alıyor. Aynı dizaynda kalmak kaydıyla bunu makro yazarak ya da başka bir şekilde çok daha kısa sürede yapma imkanı var mı? Hatta şöför isimlerinin her birine yeni bir sayfa açarak da yapabilme ihtimali varsa çok daha makbule geçer. İlgilerinize şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Forumumuza hoşgeldiniz.

Aşağıdaki kodu boş bir modüle uygulayıp denermisiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, X As Long
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("Sayfa1")
 
    S1.Columns("H:H").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns("IV:IV"), Unique:=True
 
    Application.DisplayAlerts = False
        For X = 2 To Sheets.Count
            Sheets(2).Delete
        Next
    Application.DisplayAlerts = True
 
    For X = 2 To S1.Cells(Rows.Count, "IV").End(3).Row
        S1.Range("A1").AutoFilter Field:=8, Criteria1:=S1.Cells(X, "IV")
        S1.Range("A1").CurrentRegion.Copy
        Sheets.Add , Sheets(Worksheets.Count)
        ActiveSheet.Name = S1.Cells(X, "IV")
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Cells.EntireColumn.AutoFit
        Range("A2:H" & Rows.Count).Sort Key1:=Range("D2"), Order1:=xlAscending
        Range("A:H").Subtotal _
        GroupBy:=4, _
        Function:=xlSum, _
        TotalList:=Array(5), _
        Replace:=True, _
        PageBreaks:=False, _
        SummaryBelowData:=True
        ActiveSheet.Outline.ShowLevels RowLevels:=2
        Range("E1:E" & Rows.Count).SpecialCells(xlCellTypeVisible).Font.Bold = True
        ActiveSheet.Outline.ShowLevels RowLevels:=3
        Range("A1").Select
    Next
 
    S1.Columns("IV:IV").Delete
    S1.Select
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
 
    Set S1 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hbgunay]

Hoşbulduk. İlginize çok teşekkür ederim. Tam istediğim gibi olmuş. Emeğinize sağlık.

 

[hbgunay]

Bu yazmış olduğunuz koda acaba kolon genişliklerini de eklemek mümkün mü? Eğer mümkünse karakterler 9 olması ve kolonları da aşağıda ki genişliklerde olması için ne yapmam konusunda yardımcı olursanız sevinirim.

a:9 (68 piksel)
b:15 (110 piksel)
c:22 (159 piksel)
d:30 (215 piksel)
e:6 (47 piksel)
f:6 (47 piksel)
g:4 (33 piksel)
f:5 (40 piksel)

Ayrıca kenar boşluklarını da sıfır olmasını sağlamak mümkün mü?

İlgilerinize şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Önerdiğim kodu aşağıdaki şekilde değiştirip denermisiniz. Sütun genişliklerini otomatik yapmanızda fayda görüyorum. Bahsettiğiniz ayarları yapınca bazı sütunlar okunmuyor.

Kod içindeki kırmızı renkli satırlar sizin istediğiniz sütun genişliklerini ayarlıyor. Kodu bu haliyle çalıştırıp sayfalarınızı kontrol ediniz. Daha sonra kırmızı satırların başına tek tırnak (') işareti ekleyerek pasif yapın ve mavi renkli satırın başındaki tek tırnak işaretini silip aktif hale getirip kodu tekrar deneyin. Hangisi sizin için kullanışlı ise onu kullanın.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, X As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    
    S1.Columns("H:H").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns("IV:IV"), Unique:=True
    
    Application.DisplayAlerts = False
        For X = 2 To Sheets.Count
            Sheets(2).Delete
        Next
    Application.DisplayAlerts = True
    
    For X = 2 To S1.Cells(Rows.Count, "IV").End(3).Row
        S1.Range("A1").AutoFilter Field:=8, Criteria1:=S1.Cells(X, "IV")
        S1.Range("A1").CurrentRegion.Copy
        Sheets.Add , Sheets(Worksheets.Count)
        ActiveSheet.Name = S1.Cells(X, "IV")
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Range("A2:H" & Rows.Count).Sort Key1:=Range("D2"), Order1:=xlAscending
        Range("A:H").Subtotal _
        GroupBy:=4, _
        Function:=xlSum, _
        TotalList:=Array(5), _
        Replace:=True, _
        PageBreaks:=False, _
        SummaryBelowData:=True
        ActiveSheet.Outline.ShowLevels RowLevels:=2
        Range("E1:E" & Rows.Count).SpecialCells(xlCellTypeVisible).Font.Bold = True
        ActiveSheet.Outline.ShowLevels RowLevels:=3
        Cells.Font.Size = 9
[COLOR=red]        Columns("A:A").ColumnWidth = 9
        Columns("B:B").ColumnWidth = 15
        Columns("C:C").ColumnWidth = 22
        Columns("D:D").ColumnWidth = 30
        Columns("E:E").ColumnWidth = 6
        Columns("F:F").ColumnWidth = 6
        Columns("G:G").ColumnWidth = 4
        Columns("H:H").ColumnWidth = 5
[/COLOR][COLOR=blue]        'Cells.EntireColumn.AutoFit
[/COLOR]        With ActiveSheet.PageSetup
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
        End With
        Range("A1").Select
    Next
    
    S1.Columns("IV:IV").Delete
    S1.Select
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    
    Set S1 = Nothing
    
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hbgunay]

Çok teşekkür ederim. Kodları değiştirmeme gerek kalmadı. Tam istediğim gibi yapmışsınız. Benim için önemli olan sütunlar stok ve miktar sütunları. Gerisinin baş kısmı okunsa da yetiyor. Bu makroyu yazmayı ben kaydet ile yapıyorum. Ama kod yazmayı bilmiyorum. Böyle durumlarda da tıkanıp kalıyorum. Kod yazabilmek için programcılık bilmeye gerek var mı? Programcılık bilmdeden de makro yazabilmeyi öğrenebilir miyim?

 

[Korhan Ayhan]

Merhaba,

Kod yazmayı öğrenmek için makro kaydet yöntemini bol bol kullanmanız gerekiyor. Kayıt esnasında oluşan kodları inceleyip anlamlarını kavramaya çalışın. Oluşan kodları kod penceresini açıp F8 tuşu ile adım adım çalıştırarak yaptığı işlemleri gözlemleyin. Kafanıza takılan bölümlerde VBA yardımından arama yaparak komutları inceleyebilirsiniz. Forumun dersane bölümünde açıklamalı anlatımlar bulunmaktadır. Bu konuları inceleyin ve bol bol pratik yapın. Bu şekilde belli bir süre sonra kendinizde kod yazmaya başlayabilirsiniz.

 

[hbgunay]

İlginize çok teşekkür ederim. Önerilerinizi dikkate alacağım.