Macro da hata

[HASAN SATILMIS]

Selam, Daha önceden oluşturulmuş olan bir macro var bunda hata veriyor. Ben düzeltemedim. Doğru olan macroya sadece Bir sutun ekledim Özel açıklama diye O sutunu silince macro çalışıyor.Yardımcı olanlara şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Private Sub CommandButton1_Click()
Sheets("MERKEZ DÜZENLEME").[a1:g65000].ClearFormats
Sheets("MERKEZ DÜZENLEME").[a1:g65000].ClearContents
Sheets("MERKEZ DAĞILIMI").[a2:f65000].ClearFormats
Sheets("MERKEZ DAĞILIMI").[a2:f65000].ClearContents
Sheets("MERKEZ DÜZENLEME").Select
Rows("1:40000").EntireRow.Hidden = False
For a = 2 To Cells(65000, 3).End(xlUp).Row
f = Sheets("MERKEZ DÜZENLEME").Cells(65000, 1).End(xlUp).Row
If Sheets("MERKEZ DÜZENLEME").Cells(f, 1) <> "TARİH" Then
If Sheets("MERKEZ DÜZENLEME").Cells(1, 1) <> "" Then f = f + 4
Rows(1).Copy Sheets("MERKEZ DÜZENLEME").Rows(f)
End If
Z = 0
t = 0
For b = a To Cells(65000, 3).End(xlUp).Row
If Rows(b).Hidden = False Then
mm = Cells(a, 3).Value
If mm = Cells(b, 3) Then
c = Sheets("MERKEZ DÜZENLEME").Cells(65000, 1).End(xlUp).Row + 1
Sheets("MERKEZ DÜZENLEME").Range("a" & c & ":" & "g" & c).Value = Range("a" & b & ":" & "g" & b).Value
Z = Sheets("MERKEZ DÜZENLEME").Range("g" & c) * 1
t = t + Z
Sheets("MERKEZ DÜZENLEME").Range("g" & c + 1) = t * 1
Sheets("MERKEZ DÜZENLEME").Range("f" & c + 1) = "TOPLAM"
Rows(b).Hidden = True
Rows(a).Hidden = True
End If
End If
Next
Next
nn = 1
For x = 1 To Sheets("MERKEZ DÜZENLEME").Cells(65000, 5).End(xlUp).Row
If Sheets("MERKEZ DÜZENLEME").Cells(x, 5) = "TOPLAM" Then
Sheets("MERKEZ DAĞILIMI").Cells(nn + 1, 1) = nn
nn = nn + 1
Sheets("MERKEZ DAĞILIMI").Cells(nn, 2) = Sheets("MERKEZ DÜZENLEME").Cells(x - 1, 3)
Sheets("MERKEZ DAĞILIMI").Cells(nn, 3) = Sheets("MERKEZ DÜZENLEME").Cells(x, 6)
End If
Next
MsgBox Sheets("MERKEZ DÜZENLEME").Cells(65000, 1).End(xlUp).Row
Sheets("MERKEZ DAĞILIMI").Cells(nn + 2, 3) = Application.Sum(Sheets("MERKEZ DAĞILIMI").Range("c2:" & "c" & nn + 1))
Sheets("MERKEZ DAĞILIMI").Cells(nn + 2, 2) = "GENEL TOPLAM"
Rows("1:40000").EntireRow.Hidden = False
End Sub

 

[HASAN SATILMIS]

Selam, Korhan bey öncelikle hızlı cevabınız için teşekkür ederim. Sadece bir hata var Merkez Dağılım Sayfaya Toplamları almıyor ,oda büyük bir ihtimalle Toplamlar bir sutun kaydığı içindir. Onada yardımcı olabilirmisiniz.Ben uğraştım yapamadım.

 

[Korhan Ayhan]

Merhaba,

Önceki mesajımda sadece sizin kodlarınızı çalışır duruma getirmiştim. Detaylı incelememiştim. Kullandığınız kodu yeniden derledim. Aşağıdaki kodu deneyiniz.

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Satır_1 As Long, Satı_2 As Long, Son As Long
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("VERİ GİRİŞİ")
    Set S2 = Sheets("MERKEZ DÜZENLEME")
    Set S3 = Sheets("MERKEZ DAĞILIMI")
 
    S1.Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("Z1"), Unique:=True
    S2.Cells.Clear
    S3.Cells.Clear
    Satır_1 = 1
    Satır_2 = 2
 
    For X = 2 To S1.Cells(Rows.Count, "Z").End(3).Row
        S1.Range("A1").AutoFilter Field:=3, Criteria1:=S1.Cells(X, "Z")
        S1.Range("A1").CurrentRegion.Copy S2.Cells(Satır_1, 1)
        Son = S2.Cells(Rows.Count, 1).End(3).Row
        S2.Cells(Son + 1, "F") = "TOPLAM"
        S2.Cells(Son + 1, "G") = WorksheetFunction.Sum(S2.Range(S2.Cells(Satır_1 + 1, "G"), S2.Cells(Son, "G")))
        S3.Cells(Satır_2, 1) = Satır_2 - 1
        S3.Cells(Satır_2, 2) = S1.Cells(X, "Z")
        S3.Cells(Satır_2, 3) = S2.Cells(Son + 1, "G")
        Satır_1 = Son + 3
        Satır_2 = Satır_2 + 1
    Next
 
    S2.Cells.Font.Name = "Calibri"
    S2.Cells.Font.Size = 11
    S2.Range("G:G").Style = "Currency"
    S3.Range("C:C").Style = "Currency"
    S3.Cells(Rows.Count, 2).End(3).Offset(2, 0) = "GENEL TOPLAM"
    S3.Cells(Rows.Count, 3).End(3).Offset(2, 0) = WorksheetFunction.Sum(S3.Range("C2:C" & S3.Cells(Rows.Count, 3).End(3).Row))
    S1.Range("A1").AutoFilter Field:=3
    S1.Range("Z:Z").Clear
 
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[HASAN SATILMIS]

Sayın, Korhan hocam Allah ne muradınız varsa versin. Ben 1 istedim siz EKleyipte göndermişsiniz. Şekiller için Uğraşıyordum. Siz onlarada şekil vermişsiniz. Çok teşekkür ederim.

Yardımlarınız için tekrar teşekkür ederim. Çalışmalarınızda Başarılar dilerim.
SAYGILARIMLA