Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 21-04-2017, 09:48   #1
1903emre34@gmail.com
Altın Üye
 
Giriş: 29/05/2016
Şehir: İstanbul
Mesaj: 404
Excel Vers. ve Dili:
Microsoft Excel 2013 Türkçe
Varsayılan Aynı yevmiye madde numaraları hakkında

Merhaba,

yukarıdaki yevmiye madde no aynı olanları (1,3) satırlardan silinmesi ve silerken aralıklarında, iki satır aralık oluşacak şekilde nasıl kod oluşturabiliriz? (istenen sayfa2 manuel yapılmıştır)
Eklenmiş Dosyalar
Dosya Türü: xlsx Yevmiye madde numara.xlsx (12.9 KB, 4 Görüntülenme)

Bu mesaj en son " 21-04-2017 " tarihinde saat 11:12 itibariyle 1903emre34@gmail.com tarafından düzenlenmiştir....
1903emre34@gmail.com Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-04-2017, 10:52   #2
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,298
Excel Vers. ve Dili:
2010-2016
Varsayılan

(1,3) den kastınız nedir. Bir de Sayfa2 de neden 20 değer Yevmiye Madde no 3 olanlar yok.
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 21-04-2017, 11:05   #3
1903emre34@gmail.com
Altın Üye
 
Giriş: 29/05/2016
Şehir: İstanbul
Mesaj: 404
Excel Vers. ve Dili:
Microsoft Excel 2013 Türkçe
Varsayılan

Sayfa2'deki veriler, yanlışlıkla oldu, düzelttim.
1903emre34@gmail.com Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-04-2017, 12:59   #4
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,298
Excel Vers. ve Dili:
2010-2016
Varsayılan

Aşağıdaki kodları deneyin.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub askm_Satir_Sil()
Dim SonSatir, SonSatir2 As Long
SonSatir = Range("A" & Rows.Count).End(xlUp).Row
SonSatir2 = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To SonSatir
    If Cells(i, "A") <> Empty Then
        For k = i + 3 To SonSatir2
            Sayi = WorksheetFunction.CountIf(Range("c2:c" & SonSatir2), Cells(k, 3).Value)
            If Sayi > 2 Then
                For y = 1 To 3
                    If Cells(k, "C") <> Empty Then
                        Rows(k).Delete
                    Else
                        k = k + 1
                        GoTo 10
                    End If
                Next y
            End If
            
        Next k
    End If
10:
Next
SonSatir = Range("A" & Rows.Count).End(xlUp).Row
For i = SonSatir To 3 Step -1
If Cells(i, 3).Value = Empty And Cells(i - 1, 3).Value = Empty Then
    Rows(i).Delete
End If
Next i
SonSatir = Range("C" & Rows.Count).End(xlUp).Row
For i = 3 To SonSatir
If Cells(i, 3).Value = Empty And Cells(i + 1, 3).Value <> Empty Then
    Rows(i).Insert Shift:=xlDown
    i = i + 2
End If
Next i
MsgBox "işlem tamam", vbInformation, "ASKM"
End Sub
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 21-04-2017, 23:33   #5
1903emre34@gmail.com
Altın Üye
 
Giriş: 29/05/2016
Şehir: İstanbul
Mesaj: 404
Excel Vers. ve Dili:
Microsoft Excel 2013 Türkçe
Varsayılan

Teşekkürler, kodlar ekteki dosya uyguladım ama olmadı.

Sayfa 1, uygulanan kodlar

Sayfa 2, orgınal sayfa

Sayfa 3, olması istenen sayfa
Eklenmiş Dosyalar
Dosya Türü: xlsm Yevmiye kayıt numara .xlsm (31.3 KB, 3 Görüntülenme)
1903emre34@gmail.com Çevrimdışı   Alıntı Yaparak Cevapla
Eski 22-04-2017, 21:56   #6
1903emre34@gmail.com
Altın Üye
 
Giriş: 29/05/2016
Şehir: İstanbul
Mesaj: 404
Excel Vers. ve Dili:
Microsoft Excel 2013 Türkçe
Varsayılan

Konu güncel
1903emre34@gmail.com Çevrimdışı   Alıntı Yaparak Cevapla
Eski 23-04-2017, 11:15   #7
Ziynettin
Altın Üye
 
Giriş: 17/04/2008
Şehir: istanbul
Mesaj: 354
Excel Vers. ve Dili:
office2010
Varsayılan

Dosyanız ekte, umarım istediğiniz olur.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub Aktar()
On Error Resume Next
Set sh = Sheets("Sayfa2")
a = sh.Range("A2:N" & sh.Cells(Rows.Count, 2).End(3).Row)
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a)
    If a(i, 3) <> "" Then
        say = say + 1
        b(say, 1) = a(i, 1)
        b(say, 2) = a(i, 2)
        For y = 4 To UBound(a, 2)
            b(say, y) = a(i, y)
        Next y
        If a(i, 3) = a(i + 1, 3) Then
            n = n + 1
            b(say, 3) = a(i, 3) & "|" & n
         Else
            b(say, 3) = a(i, 3) & "|" & n + 1
            n = 0
        End If
    End If
Next i

tbl = Array(b)
b = Empty
n = Empty
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
say = 0
For i = 1 To UBound(a)
    deg = tbl(0)(i, 3)
    d1(Split(deg, "|")(0)) = d1(Split(deg, "|")(0)) + 1
    If Not d.exists(deg) Then
        say = say + 1
        d.Add deg, say
        For y = 1 To UBound(a, 2)
            b(say, y) = tbl(0)(i, y)
        Next y
        b(say, 3) = Split(deg, "|")(0)
    End If
Next i

tbl = Array(b)
b = Empty: deg = Empty
ReDim b(1 To UBound(a) + d1.Count * 2, 1 To UBound(a, 2))
say = 0
For i = 1 To UBound(a)
    deg = tbl(0)(i, 3)
    If deg <> tbl(0)(i - 1, 3) Then
        say = say + 3
    Else
        say = say + 1
    End If
    For y = 1 To UBound(a, 2)
        b(say - 2, y) = tbl(0)(i, y)
    Next y
Next i
Application.ScreenUpdating = False
With Sheets("Sayfa3")
.Range("A3:N" & Rows.Count).ClearContents
.[A3].Resize(UBound(a) + d1.Count * 2, UBound(a, 2)) = b
.Select
End With
Application.ScreenUpdating = True
MsgBox "İşlem Tamam....", vbInformation
End Sub
Eklenmiş Dosyalar
Dosya Türü: xlsm Yevmiye kayıt numara .xlsm (41.6 KB, 9 Görüntülenme)
Ziynettin Çevrimdışı   Alıntı Yaparak Cevapla
Eski 23-04-2017, 13:07   #8
1903emre34@gmail.com
Altın Üye
 
Giriş: 29/05/2016
Şehir: İstanbul
Mesaj: 404
Excel Vers. ve Dili:
Microsoft Excel 2013 Türkçe
Varsayılan

çok teşekkürler,

hayırlı günler
1903emre34@gmail.com Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 22:00


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Torna - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Hurda - Lingerie - Dyeing Machine - Çorlu Temizlik- Karton Bardak- Çorlu Pimapenci- İstanbul Avukat- Çorlu Kekemelik- Edirne Su Arıtma- Çorlu Perde Yıkama- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Çorlu İnşaat- Marmara Ereğlisi Yurt- Çorlu Solucan Gübresi- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Su Deposu Temizliği- Bakır Sülfat- Rampa- Rotary-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden