Macro ile bazı verileri ayırıp koşula göre karşılığına gelen değerlerin yazılması

[levoni]

Merhaba Değerli Arkadaşlar,
Çok uzun zaman alan bir dizi işlemlerin bazı kısımlarının macro yardımıyla kısa sürede yapıp zamandan kazanmak istiyorum.Bu konuda vaktiniz olduğunda zaman ayırıp yardımcı olabilirseniz çok sevinirim.
Yapmak istediklerimi daha anlaşılır olması açısından madde madde yazmak istiyorum. Herhalükarda ana dosyayı ve olması gereken dosyayı ekte gönderiyorum

1-F sütununda 900 ile başlayan tüm kayıtların ayrı bir sheette "Kıbrıs" adıyla bu listeden çıkartılıp "Kıbrıs" sheetine eklenmesi gerekiyor.

2- Bu shette en son sütuna bir kolon açarak F sütununda "POSARA" yazan satırların karşısına yani yani karşısındaki hücreye "KARGO" yazması gerekiyor.

3-Aynı şekilde F sütununda "SF" ile başlayan verilerin hemen yan sütunundaki hücreye "SERVİS FİRMASI" yazması gerekiyor
4-Bunların dışında kalan diğer verilerin son harfi ne ise o harfin ilgili yan sütuna yazılması gerekiyor.Örneğin 340K ise burada "K" yazması gerekiyor.

5-Bütün bu işlemler yapıldıktan sonra "Tc" isimli sheette yer alan "D" sütununda yer alan
3 farklı değere göre (POS,PİNPAD, SİMCARD) aynı dosyada farklı sheettler oluşturması gerekiyor.Örneğin sheetlerin adı şu şekilde olması gerekiyor ; diğer bir ifadeyle bütün pos lar bir sheette bütün pinpad ler satır sütün sayısı bozulmadan ayrı bir sheette olması gerekiyor
"Tc_Pos" diğer sheet "TC_Pinpad" gibi


Bu çalışmada olması gereken örnek dosyayı "Olması Gereken Örnek_1_ Tüm Seriler.xlsx" dosyasında bulabilirsiniz.

Biraz uzun yazdım kusura bakmayın, yardımlarınız için şimdiden çok tşk ler

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Kod içindeki sayfa isimleri ile kendi dosyanızdaki isimleri aynı yapmayı unutmayın.

Sub DÜZENLE()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim S3 As Worksheet, S4 As Worksheet
    Dim X As Long
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("Tc")
    Set S2 = Sheets("Kıbrıs")
    Set S3 = Sheets("Tc_Pos")
    Set S4 = Sheets("Tc_Pinpad")
    Set S5 = Sheets("Tc_Simcard")
 
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=6, Criteria1:="=900*"
    S1.Range("A1").CurrentRegion.Copy S2.Range("A1")
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=6
 
    For X = S1.Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        If Left(S1.Cells(X, "F"), 3) = "900" Then S1.Rows(X).Delete
    Next
 
    For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        If UCase(S1.Cells(X, "F")) = "POSARA" Then
            S1.Cells(X, "J") = "KARGO"
        ElseIf Left(UCase(S1.Cells(X, "F")), 2) = "SF" Then
            S1.Cells(X, "J") = "SERVİS FİRMASI"
        Else
            S1.Cells(X, "J") = Right(S1.Cells(X, "F"), 1)
        End If
    Next
 
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=4, Criteria1:="POS"
    S1.Range("A1").CurrentRegion.Copy S3.Range("A1")
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=4
 
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=4, Criteria1:="PİNPAD"
    S1.Range("A1").CurrentRegion.Copy S4.Range("A1")
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=4
 
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=4, Criteria1:="SİMCARD"
    S1.Range("A1").CurrentRegion.Copy S5.Range("A1")
    S1.Range("$A$1:$J$1048576").AutoFilter Field:=4
 
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[zodiak]

hocam verdiğiniz kodu boş bir modülemi yazacağız benim biraz kafam karıştı

 

[Korhan Ayhan]

hocam verdiğiniz kodu boş bir modülemi yazacağız benim biraz kafam karıştı

Merhaba,

Niçin kafanız karıştı?

"Sub...." ile başlayan kodlar genellikle "modüle" uygulanır. Fakat sayfanın kod bölümünde de kullanabilirsiniz.

 

[levoni]

Korhan Bey merhaba günaydın,
Ellerinize aklınıza sağlık.Çok tşk ederim geç saatlerde bir sürü kod yazmışsınız zahmet verdik size.
Çok güzel olmuş. Size şimdi cevap verebildim kusura bakmayın