Verı Aktarımı ve Ayıklama

[49610]

Merhaba Arkadaşlar,

Bir konuda yardım edebilir misiniz?

Toplu sms gönderdiğim müşterilerim var. Bunları bir sayfada listeliyorum. Yeni bir müşteri listesi daha geliyor ve yeni gelen listeyi, eski listeye ekliyor ve her iki listede olanları da tek hale getiriyorum. Bütün bunlardan sonra SMS ISTEMEYEN müşteri listem ile karşılaştırıyor ve sms almak istemeyenleri de listeden çıkarıp, GÜNCEL listemi oluşturuyorum.

Bu işlemleri düşey ara formülü ile yapıyordum, fakat listemdeki gsm no sayısı birkaç yüz bin olunca işler epey zorlaştı, çok vakit almaya başladı.
Dosya örneğimi ekte gönderiyorum, yardımcı olabilecek arkadaşlara şimdiden teşekkürler.

 

[tahsinanarat]

Karşılaştırmada hangi kriteri baz alıyorsunuz.

 

[49610]

Gsm Nolarını dikkate alıyorum.

 

[49610]

Sub Birlestir()

ActiveWorkbook.RefreshAll
Dim i As Integer, soni As Long, sons As Long

Application.ScreenUpdating = False
Sheets("GUNCELLENMISVERILER").Select
Range("A2:L" & Rows.Count).ClearContents

'For i = 1 To Worksheets("Elif Ezgen").Count
'Worksheets.Count
'With Sheets(i)
With Sheets("MEVCUTKAYITLAR")
If .Name <> "GUNCELLENMISVERILER" And .Range("G2") <> "" Then
soni = .Cells(Rows.Count, "G").End(xlUp).Row
sons = Cells(Rows.Count, "G").End(xlUp).Row + 1
.Range("A2:L" & soni).Copy Range("A2:L" & sons)
End If
End With


With Sheets("YENIGELENVERILER")
If .Name <> "GUNCELLENMISVERILER" And .Range("G2") <> "" Then
soni = .Cells(Rows.Count, "G").End(xlUp).Row
sons = Cells(Rows.Count, "G").End(xlUp).Row + 1
.Range("A2:L" & soni).Copy Range("A" & sons)
End If
End With
End Sub


Yukarıdaki kodla, eski ve yeni verileri birleştirdim.


Sub Makro1()
'
' Makro1 Makro
'

'
Columns("A:L").Select
ActiveWorkbook.Worksheets("GUNCELLENMISVERILER").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("GUNCELLENMISVERILER").Sort.SortFields.Add Key:= _
Range("G2:G7"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("GUNCELLENMISVERILER").Sort.SortFields.Add Key:= _
Range("D27"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("GUNCELLENMISVERILER").Sort.SortFields.Add Key:= _
Range("E2:E7"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("GUNCELLENMISVERILER").Sort.SortFields.Add Key:= _
Range("F2:F7"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("GUNCELLENMISVERILER").Sort
.SetRange Range("A1:L7")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$L$7").RemoveDuplicates Columns:=7, Header:=xlYes
End Sub

Bu makro ile de filtreleyip, mükerrer olanları sildim.

Şimdi ihtiyacım olan şu;



GUNCELLENMISVERILER sayfası (G2 den itibaren) G sütununda bulunan gsm numaralarından herhangi biri,
SMSATILMAYACAK sayfası (G2 den itibaren) G sütununda bulunan gsm numaralarından herhangi birine eşit ise;
GÜNCELLENMISVERILER sayfasındaki numaranın bulunduğu satırı tamamen silmek
istiyorum.

Bu kodun yazılmasına yardımcı olur musunuz,

Saygılarımla,

 

[tahsinanarat]

Ekli dosyanızı inceleyeniz

GUNCELLENMISVERILER sayfasındaki H sutunu SMSISTEMEYENLER sayfasındaki telefon numaralarının tesbiti için kullanılmıştır, istemeyenlerisil makrosu ile de H sutununda hücre değeri 0 (sıfır) dan büyük olan satırların silinmesi için kullanılmıştır. Birleştir ve mükürrer kayıt silme işlemini siz hallettiğinizi söylemiştiniz zaten.

Option Explicit
Sub duzenle()
Dim i As Long
Dim ALetzte As Long
Dim xWert As String
Dim rng As Range
Application.ScreenUpdating = False
ALetzte = IIf(IsEmpty(Cells(Rows.Count, 7)), Cells(Rows.Count, 7).End(-4162).Row, Rows.Count)
For i = 1 To ALetzte
xWert = Cells(i, 7).Value
Set rng = Sheets("SMSISTEMEYENLER").Columns(7).Find(xWert, _
lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then Cells(i, 8).Value = Sheets("SMSISTEMEYENLER").Range("G" & rng.Row).Value
Next i
Application.ScreenUpdating = True
istemeyenlerisil
End Sub

Sub istemeyenlerisil()
Dim SUT, SAT As Integer
For SUT = 1 To Cells(65536, "G").End(3).Row
Next
For SUT = Cells(65536, "H").End(3).Row To 1 Step -1
If Cells(SUT, "H") > 0 Then
Cells(SUT, "H").EntireRow.Delete SHIFT:=xlUp
End If
Next
End Sub

 

[49610]

Tahsin Bey,

Teşekkür ederim, tam istediğim gibi, emeğinize sağlık.

Saygılar,

 

[tahsinanarat]

Rica ederim.