• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tabloyu sadeleştirmek

igultekin2000

igultekin2000

Katılım
5 Eylül 2007
Mesajlar
1,247
Excel Vers. ve Dili
ofis 2010
iyi akşamlar; internetten inen SGK tablosunu neredeyse son aşamaya geldi. Son olarak Tablonun son haline gelmesi için, çözemediğim eksikliği kaldı. resim ve örnek dosyayı yüklüyorum. Teşekkürler.
 

Ekli dosyalar

  • Tablo.xlsx
    Tablo.xlsx
    17.1 KB · Görüntüleme: 10
  • Resim_Tablo.jpg
    Resim_Tablo.jpg
    147.6 KB · Görüntüleme: 8
Merhaba.

Aşağıdaki kod'u sayfanın kod bölümüne uygulayarak çalıştırın.
Sorulacak soruya isteğinize uygun cevabı vererek işlemi tamamlayın.
.
Kod: 
[B][COLOR="blue"]Sub SGK_5510_BUL()[/COLOR][/B]
son = Cells(Rows.Count, 1).End(3).Row
For sat = 3 To son
    If Cells(sat, "D") = 5510 Then
        satilk = sat + 1
        aranan = Cells(sat, "F")
            For satt = satilk To son
                If satt = son Then Exit For
                If Cells(satt, "D") = "" And Cells(satt, "G") = aranan Then
                    Cells(satt, "D") = 5510
                    sat = satt + 1
                    Exit For
                End If
            Next
    End If
Next
Range("A1:G" & son).AutoFilter Field:=4, Criteria1:="5510"
[COLOR="Red"]cvp = MsgBox("5510 ile ilgili eşleştirmeler yapıldı ve D sütununa buna göre filtre uygulandı." & vbLf & _
    "-- 5510 OLMAYAN satırları silmek için EVET'i" & vbLf & _
    "-- FİLTRE'yi kaldırmak için HAYIR'ı" & vbLf & _
    "-- Belgeyi bu haliyle bırakmak için İPTAL'i" & vbLf & _
    "     seçin.", vbYesNoCancel)[/COLOR]
If cvp = vbYes Then
    Range("A1:G" & son).AutoFilter Field:=4, Criteria1:="<>" & "5510"
    Range("A2:G" & son).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    Range("A1:G" & son).AutoFilter Field:=4
ElseIf cvp = vbNo Then
    Range("A1:G" & son).AutoFilter
Else
    GoTo 10
End If
10:
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B][COLOR="Blue"]End Sub[/COLOR][/B]
 
kısmen kod tamam

Ömer BARAN' Alıntı:
Merhaba.

Aşağıdaki kod'u sayfanın kod bölümüne uygulayarak çalıştırın.
Sorulacak soruya isteğinize uygun cevabı vererek işlemi tamamlayın.
.
Kod: 
[B][COLOR="blue"]Sub SGK_5510_BUL()[/COLOR][/B]
son = Cells(Rows.Count, 1).End(3).Row
For sat = 3 To son
    If Cells(sat, "D") = 5510 Then
        satilk = sat + 1
        aranan = Cells(sat, "F")
            For satt = satilk To son
                If satt = son Then Exit For
                If Cells(satt, "D") = "" And Cells(satt, "G") = aranan Then
                    Cells(satt, "D") = 5510
                    sat = satt + 1
                    Exit For
                End If
            Next
    End If
Next
Range("A1:G" & son).AutoFilter Field:=4, Criteria1:="5510"
[COLOR="Red"]cvp = MsgBox("5510 ile ilgili eşleştirmeler yapıldı ve D sütununa buna göre filtre uygulandı." & vbLf & _
    "-- 5510 OLMAYAN satırları silmek için EVET'i" & vbLf & _
    "-- FİLTRE'yi kaldırmak için HAYIR'ı" & vbLf & _
    "-- Belgeyi bu haliyle bırakmak için İPTAL'i" & vbLf & _
    "     seçin.", vbYesNoCancel)[/COLOR]
If cvp = vbYes Then
    Range("A1:G" & son).AutoFilter Field:=4, Criteria1:="<>" & "5510"
    Range("A2:G" & son).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    Range("A1:G" & son).AutoFilter Field:=4
ElseIf cvp = vbNo Then
    Range("A1:G" & son).AutoFilter
Else
    GoTo 10
End If
10:
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B][COLOR="Blue"]End Sub[/COLOR][/B]
Genişletmek için tıkla ...

Baran Bey önce teşekkür ederim. Benim için önemli olan 5510 ilgili satıra yazdırıyor. Filtreleme ve silme işlemi hatalı oluyor. 5510 ilgili satıra yazdırdıktan sonra, G sütunundaki değerler kalıp, diğer satırların silinmesi şeklinde olması gerekiyordu.
 
Kod: 
Sub ASKM()
Son = Cells(Rows.Count, 1).End(3).Row
For sat = 3 To Son
    If Cells(sat, "D") = 5510 And Cells(sat, "F") <> 0 Then
        satilk = sat + 1
        aranan = Cells(sat, "F")
            For satt = satilk To Son
                If satt = Son Then Exit For
                If Cells(satt, "D") = "" And Cells(satt, "G") = aranan Then
                    Cells(satt, "D") = 5510
                    Rows(sat).Delete
                    Exit For
                End If
            Next
    End If
Next
    
End Sub
 
sorun çözülmedi

askm' Alıntı:
Kod: 
Sub ASKM()
Son = Cells(Rows.Count, 1).End(3).Row
For sat = 3 To Son
    If Cells(sat, "D") = 5510 And Cells(sat, "F") <> 0 Then
        satilk = sat + 1
        aranan = Cells(sat, "F")
            For satt = satilk To Son
                If satt = Son Then Exit For
                If Cells(satt, "D") = "" And Cells(satt, "G") = aranan Then
                    Cells(satt, "D") = 5510
                    Rows(sat).Delete
                    Exit For
                End If
            Next
    End If
Next
    
End Sub
Genişletmek için tıkla ...

uyguladım ama silme işlemi yapmadı.
 
Kod: 
Sub ASKM()
Son = Cells(Rows.Count, 1).End(3).Row
For sat = Son To 3 Step -1
    If Cells(sat, "D") = 5510 And Cells(sat, "F") <> 0 Or Cells(sat, "D") = 5510 And Cells(sat, "F") = "" Then
        satilk = sat + 1
        aranan = Cells(sat, "F")
            For satt = satilk To Son
                If satt = Son Then Exit For
                If Cells(satt, "D") = "" And Cells(satt, "G") = aranan Then
                    Cells(satt, "D") = 5510
                    Rows(sat).Delete
                    Exit For
                End If
            Next
    End If
Next
    
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst