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: 227
Excel Vers. ve Dili:
Microsoft Excel 2016 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: 737
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 2002- 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: 227
Excel Vers. ve Dili:
Microsoft Excel 2016 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: 737
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 2002- 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: 227
Excel Vers. ve Dili:
Microsoft Excel 2016 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: 227
Excel Vers. ve Dili:
Microsoft Excel 2016 Türkçe
Varsayılan

Konu güncel
1903emre34@gmail.com Çevrimdışı   Alıntı Yaparak Cevapla
Eski Dün, 11:15   #7
Ziynettin
Altın Üye
 
Giriş: 17/04/2008
Şehir: istanbul
Mesaj: 294
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, 5 Görüntülenme)
Ziynettin Çevrimdışı   Alıntı Yaparak Cevapla
Eski Dün, 13:07   #8
1903emre34@gmail.com
Altın Üye
 
Giriş: 29/05/2016
Şehir: İstanbul
Mesaj: 227
Excel Vers. ve Dili:
Microsoft Excel 2016 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 19:10


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

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - Investing - Hurda - Kobi Danışmanlık - Tekirdağ Samsung - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu OSGB - Lingerie - Dyeing Machine - Çorlu Temizlik- Didim Çatı İnşaat- Çorlu Ambar- Hava Çekimi- Hazır Site- SEO- Çorlu Estetik
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden