koddaki revizyon

[amelie]

Arkadaşlar ekteki dosyadaki kodu düzenlemek istiyorum ancak bir türlü başaramadım.Sizden yardım rica ediyorum.
Kodlar gayet güzel çalışıyor (Sayın Veysel Emre'ye teşekkür ederim) ancak İlgili Shetteki Z sütununa kadar olan biligiler için de çalışmasını istiyorum.
içinde anlayamadığım satırlar bulunduğundan mevcut bilgilerimle bu değişikliği yapamadım.Yardımlarını esirgemesseniz sevinirim.
Saygılarımla.

 

[Ferhat Pazarçevirdi]

Bu dosyada ne kod ne de formül var. Acaba yanlış dosya göndermiş olabilir misiniz?

 

[amelie]

özür

Haklısın özür dilerim dosyayı eklemeyi unutmuşum ( kodlu halini)
şimdi ekledim.
Uyarı için teşekkür ederim.

 

[amelie]

Arkadaşlar bir yardım lütfen, çıkamadım işin içinden inanın!

 

[Ferhat Pazarçevirdi]

İsteğiniz tam olarak anlaşılamadı sanırım.

A ve B sütunlarında şu anda var olan veriler gibi, C ve D'de, E ve F'de, G ve H'de vesair, en son Y ve Z'de de olsaydı mı demek istiyorsunuz?

 

[amelie]

Sayın Fpc İlginize teşekkür ediyorum.Ve haklısınız pek iyi anlatamamış olabilirim ancak aynen dediğiniz gibi Tablodaki bilgiler Z sütununa kadar olsaydı nasıl bir değişiklik yapmam gerekirdi? Teşekkür ediyorum.

 

[Ferhat Pazarçevirdi]

Kodlarınızı aşağıdaki gibi revize ediniz.

Sub Duzenleme()
Dim sh As Worksheet, shT As Worksheet, shA As Worksheet, shL As Worksheet
Dim hcr As Range
Dim i As Long, sonSS As Long, j As Long, sonS As Long
Dim sonA As Long, sonL As Long
Dim deg As Variant
Set sh = Sheets("59882HAV1")
On Error Resume Next
Set shT = Sheets("TÜMÜ")
shT.Cells.ClearContents
If Err.Number <> 0 Then
   Set shT = Sheets.Add(, Sheets(Sheets.Count))
   shT.Name = "TÜMÜ"
   Err.Number = 0
End If
Set shA = Sheets("AMIR")
shA.Cells.ClearContents
If Err.Number <> 0 Then
   Set shA = Sheets.Add(, Sheets(Sheets.Count))
   shA.Name = "AMIR"
   Err.Number = 0
End If
Set shL = Sheets("LEHDAR")
shL.Cells.ClearContents
If Err.Number <> 0 Then
   Set shL = Sheets.Add(, Sheets(Sheets.Count))
   shL.Name = "LEHDAR"
   Err.Number = 0
End If
For i = 1 To sh.Cells(1, 1).End(xlToRight).Column Step 2
    sonSS = sh.Cells(65536, i).End(xlUp).Row + 1
    For Each hcr In sh.Range(sh.Cells(2, i), sh.Cells(sonSS - 1, i)).Cells
        If Trim(hcr.Value) = "AMIR KAYITLAR" Or Trim(hcr.Value) = "LEHDAR KAYITLAR" Then
           deg = hcr.Value
        Else
           If i = 1 Then
              j = 1
           Else
              j = i + 1
           End If
           sonS = shT.Cells(65536, j).End(xlUp).Row + 1
           shT.Cells(sonS, j).Value = deg
           shT.Cells(sonS, j + 1).Value = hcr.Value
           shT.Cells(sonS, j + 2).Value = hcr.Offset(0, 1).Value
           If Trim(deg) = "AMIR KAYITLAR" Then
              sonA = shA.Cells(65536, j).End(xlUp).Row + 1
              shA.Cells(sonA, j).Value = deg
              shA.Cells(sonA, j + 1).Value = hcr.Value
              shA.Cells(sonA, j + 2).Value = hcr.Offset(0, 1).Value
           Else
              sonL = shL.Cells(65536, j).End(xlUp).Row + 1
              shL.Cells(sonL, j).Value = deg
              shL.Cells(sonL, j + 1).Value = hcr.Value
              shL.Cells(sonL, j + 2).Value = hcr.Offset(0, 1).Value
           End If
        End If
    
    Next
Next i
Set sh = Nothing
Set shT = Nothing
Set shA = Nothing
Set shL = Nothing
End Sub

 

[amelie]

Sayın fpc öncelikle ilginiz ve emeğiniz için sonsuz teşekkür ediyorum.
Kodunuzu dosyaya uyguladım ancak karışık bir listeleme yaptı.Şöyle ki sayfadaki 1 satırda Z sütununa kadar başlıklar mevcut ve ayıklama işlemi için bu sütun başlıklarında bulunan bilgilerinde dahil olması gerek.Eski halinde c sütununa kadar ayarlandığı için sorunsuz çalışıyordu o bakımdan acaba o kodlarda Z sütununa kadar olan alanı tanıtabilmemiz mümkün mü?
Umarım bu ifademi bir saygısızlık olarak algılamassınız,kod bilgim çok iyi düzeyde olmadığı için kodları yorumlamam hem uzun hem de zaman alıyor ben yalnızca şuan ki çalışan biçimiyle uygulayamadığımı anlatmak istiyorum yalnızca...eski kodalara bir haftadır kafa yorduğumdan ifadeleri ve kurguyu ( sizin kodlarınız için diyorum) çok fazla yorumlayamıyorum şuan için...
Uzattım epeyce farkındayım...Herşey için çok ama çok teşekkür ediyorum.
sonsuz sevgilerimi letiyorum size.
Saygılarımla.

 

[Ferhat Pazarçevirdi]

Kodları tekrar aşağıdaki gibi revize ettim. ÖRnekte de göreceğini gibi Z'ye kadar değil, sizin girdiğiniz en son kolona kadar işlem yapmakta.

Örnekte denemeler için kayıt sayısını kısalttım. Siz 10000 satırlık verinizi ilave edip deneyebilirsiniz. Ama işlem süresi oldukça uzun olabilir.

Yapmak istediğiniz şey bundan farklıysa, lütfen biraz daha detaylı açıklayınız

Option Explicit
Sub Duzenleme()
Dim sh As Worksheet, shT As Worksheet, shA As Worksheet, shL As Worksheet
Dim hcr As Range
Dim i As Long, sonSS As Long, j As Long, sonS As Long, y As Integer
Dim sonA As Long, sonL As Long
Dim deg As Variant
Set sh = Sheets("59882HAV1")
On Error Resume Next
Set shT = Sheets("TÜMÜ")
shT.Cells.ClearContents
If Err.Number <> 0 Then
   Set shT = Sheets.Add(, Sheets(Sheets.Count))
   shT.Name = "TÜMÜ"
   Err.Number = 0
End If
Set shA = Sheets("AMIR")
shA.Cells.ClearContents
If Err.Number <> 0 Then
   Set shA = Sheets.Add(, Sheets(Sheets.Count))
   shA.Name = "AMIR"
   Err.Number = 0
End If
Set shL = Sheets("LEHDAR")
shL.Cells.ClearContents
If Err.Number <> 0 Then
   Set shL = Sheets.Add(, Sheets(Sheets.Count))
   shL.Name = "LEHDAR"
   Err.Number = 0
End If
y = 1
For i = 1 To sh.Cells(1, 1).End(xlToRight).Column Step 2
    sonSS = sh.Cells(65536, i).End(xlUp).Row + 1
    For Each hcr In sh.Range(sh.Cells(2, i), sh.Cells(sonSS - 1, i)).Cells
        If Trim(hcr.Value) = "AMIR KAYITLAR" Or Trim(hcr.Value) = "LEHDAR KAYITLAR" Then
           deg = hcr.Value
        Else
           sonS = shT.Cells(65536, y).End(xlUp).Row + 1
           shT.Cells(sonS, y).Value = deg
           shT.Cells(sonS, y + 1).Value = hcr.Value
           shT.Cells(sonS, y + 2).Value = hcr.Offset(0, 1).Value
           If Trim(deg) = "AMIR KAYITLAR" Then
              sonA = shA.Cells(65536, y).End(xlUp).Row + 1
              shA.Cells(sonA, y).Value = deg
              shA.Cells(sonA, y + 1).Value = hcr.Value
              shA.Cells(sonA, y + 2).Value = hcr.Offset(0, 1).Value
           Else
              sonL = shL.Cells(65536, y).End(xlUp).Row + 1
              shL.Cells(sonL, y).Value = deg
              shL.Cells(sonL, y + 1).Value = hcr.Value
              shL.Cells(sonL, y + 2).Value = hcr.Offset(0, 1).Value
           End If
        End If
    Next
y = y + 3
Next i
y = 1
For i = 1 To sh.Cells(1, 1).End(xlToRight).Column / 2
    With shT
         .Cells(1, y) = "Kayıt Cinsi"
         .Cells(1, y + 1) = "İşlem Referansı"
         .Cells(1, y + 2) = "İşlem Sıra No"
         .Cells.EntireColumn.AutoFit
    End With
    With shA
         .Cells(1, y) = "Kayıt Cinsi"
         .Cells(1, y + 1) = "İşlem Referansı"
         .Cells(1, y + 2) = "İşlem Sıra No"
         .Cells.EntireColumn.AutoFit
    End With
    With shL
         .Cells(1, y) = "Kayıt Cinsi"
         .Cells(1, y + 1) = "İşlem Referansı"
         .Cells(1, y + 2) = "İşlem Sıra No"
         .Cells.EntireColumn.AutoFit
    End With
    y = y + 3
Next i
Set sh = Nothing
Set shT = Nothing
Set shA = Nothing
Set shL = Nothing
End Sub

 

[amelie]

sayın fpc kod revizyonu hakkında.

Sayın fpc Merhabalar üstad.
Öncelikle sorunuma karşı göstermiş olduğunuz ilgi ve alakadan dolayı size çok çok teşekkür ediyorum.Bu konuda sizi fazlasıyla meşgul ettiğim için de ayrıca özür diliyorum.En son göndermiş olduğunuz yapıyı da mevcut dosyama uyarladığımda sonucun olması gerekenden farklı olduğunu ve sorunu yanlış ifade etmiş olduğumu düşünerek sizin de belirttiğiniz gibi daha detaylı bir açıklama ve asıl dosyanın kendisini göndermek teşebbüsünde affınıza sığınarak bulunuyorum.
Ekteki dosyada görünen bilgilerin ( ki aslında 40000 den fazla bir kayıttır) içindeki mevcut bilgiler karışık bir şekilde bulunmaktadır.ilk satır bilgileri sütun başlıkları olmakla birlikte.1.sütun baz alınarak göreceğiniz üzere AMIR KAYITLAR ifadesinin altında amir kayıtları LEHDAR KAYITLAR ifadesinin altında lehdar kayırları listelenmektedir.Ancak bu kayıtlar tekrarlı ve karıştır.Burda yapılmak istenilen AMIR KAYIRLARIN ve LEHDAR KAYITLARIN ayrı sheet'lerde listelenmesi durumudur.
Eğer bu konuda sizi fazlasıyla meşgul ettiyse özür diliyorum ve tüm bunca desteğiniz ve ilginiz için de çok teşekkür ediyorum.
İçten sevgi ve selamlarımla.
İyi çalışmalar.