Alfanümerik dataların bulunduğu sütundakileri, aradaki boşlukları yok ederek 2 sütun sağa listelemek

[Tevfik_Kursun]

Günaydın Arkadaşlar,
B7:B40 arasında alfanümerik datalar oluşturulmuş. bunları, aradaki boşlukları yok ederek 2 sütun sağa D7 den itibaren örnekteki gibi listelemek istiyorum. Yardımcı olursanız sevinirim.
Saygılarımla

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Bu makroyu oluşturup problemimi çözdüm. Farklı alternatif olursa incelemeye ve öğrenip uygulamaya hazırım.

Sub Boşluklari_Sil()
    Range("B7:C40").Select
    Selection.Copy
    Range("D7").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("D7:D40").Select

    ActiveSheet.Range("$D$7:$D$40").RemoveDuplicates Columns:=1, Header:=xlNo
   
    For x = 0 To 33
        Cells(7 + x, 4).Select
            If Cells(7 + x, 4).Value <> "" Then
                GoTo 99
              Else
                Selection.Delete Shift:=xlUp
            End If
99:
    Next x
    Range("D5").Select
End Sub

Saygılarımla

 

[hamitcan]

Ben bir örnek yaptım.

Sub Test()
 Columns(4).Clear
 Columns(2).Copy Columns(4)
 Set ilkhucre = Columns(4).Find(what:="*")
 For i = Cells(65536, 4).End(3).Row To ilkhucre.Row Step -1
    If Len(Cells(i, 4)) = 0 Then Rows(i).Delete
 Next
End Sub

 

[Tevfik_Kursun]

Merhaba Sayın Hamitcan,
İlginize teşekkür ederim. Satır değil hücre silecek. Yine de tersten başladığı için farklı bir yöntem.

If Len(Cells(i, 4)) = 0 Then Row(i).Delete

yerine

If Len(Cells(i, 4)) = 0 Then Cells(i, 4).Delete

koyarak çözümledim.
Belki daha farklı çözümler bulunabilir.
İyi çalışmalar

 

[Asri]

Aşağıdaki kod örnek dosyadaki boş hücreleri algılamıyor.
Sanırım biçimlendirme yada özel karakter gibi bir durum var.
Boş hücreleri seçip del tuşu ile içini temizleyince kod çalıyor.
Örnek olması açısından paylaştım. Mevcut dosya için çok uygun değil.

Sub bossil()
   Range("B:B").Copy Range("E1")
   Range("E8:E1000").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub

 

[Tevfik_Kursun]

Merhaba Asri Hocam,
İlginç! Boşluklar "" olmasına rağmen mutlaka hücreyi delete etmek gerekiyor. Kod değer karşılığı da yok. Neden olabilir acaba?
Saygılarımla

 

[Asri]

Merhaba Asri Hocam,
İlginç! Boşluklar "" olmasına rağmen mutlaka hücreyi delete etmek gerekiyor. Kod değer karşılığı da yok. Neden olabilir acaba?
Saygılarımla

Tam olarak bilemiyorum ancak excel bir şekilde boş olarak görmüyor.
Görünmeyen özel karakter içeriyor olabilir. Hücre içinde Alt+enter , tab v.b de olabilir.

 

[Tevfik_Kursun]

Merhaba Asri Hocam,
Ben de sebebi bulamadım. Bir yol daha düşünüyorum, ama uygulayamadım. Diziye alınıp, çözümlenip D7 den itibaren yazdırılamaz mı?
Saygılarımla

 

[Korhan Ayhan]

Dizi yöntemiyle çözüm;

Option Explicit

Sub Bosluklari_Temizleyip_Listele()
    Dim Veri As Variant, Son As Long
    Range("D7:D" & Rows.Count).Clear
    Son = Cells(Rows.Count, 2).End(3).Row
    Veri = Filter(Application.Transpose(Application.Evaluate("=IF(LEN(B7:B" & Son & ")>0,B7:B" & Son & ",""#"")")), "#", False)
    Range("D7").Resize(UBound(Veri) + 1) = Application.Transpose(Veri)
End Sub

 

[Asri]

Merhaba Asri Hocam,
Ben de sebebi bulamadım. Bir yol daha düşünüyorum, ama uygulayamadım. Diziye alınıp, çözümlenip D7 den itibaren yazdırılamaz mı?
Saygılarımla

@hamitcan , ın kodu yeterli değil mi? cells delete olarak düzenlenince isteneni veriyor.

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize çok teşekkür ederim.
Sayın Asri Hocam,
2. mesajdaki, soruyu sorduktan sonra oluşturabildiğim kendi çözümüm bile yeterli. Ancak farklı yöntemleri düşünmek bile insanı canlı tutuyor.
Saygılarımla

 

[Korhan Ayhan]

Bu da döngü ile dizi yöntemi;

Option Explicit

Sub Bosluklari_Temizleyip_Listele()
    Dim Veri As Variant, Son As Long, X As Long, Say As Long
   
    Range("D7:D" & Rows.Count).Clear
   
    Son = Cells(Rows.Count, 2).End(3).Row
    If Son <= 7 Then Son = 8
   
    Veri = Range("B7:B" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 1)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Len(Veri(X, 1)) <> 0 Then
            Say = Say + 1
            Liste(Say, 1) = Veri(X, 1)
        End If
    Next
   
    If Say > 0 Then Range("D7").Resize(Say) = Liste
End Sub

 

[Haluk]

Bu da "Google Sheets" ile tek bir formülle elde edilen sonuç;



.

 

[Korhan Ayhan]

Başka bir alternatif;

ADO;

Option Explicit

Sub Bosluklari_Temizleyip_Listele()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No;Imex=1"""

    Sorgu = "Select * From [Sayfa1$B7:B] Where Len(F1)>0"
   
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
   
    Range("D7:D" & Rows.Count).Clear
    Range("D7").CopyFromRecordset Kayit_Seti
    With Range("D7").Resize(Kayit_Seti.RecordCount)
        .NumberFormat = "General"
        .Value = .Value
    End With
   
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
 
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
End Sub

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
12. ve 14. mesajlarınız için ayrıca teşekkür ederim.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Google çözümlerinizi imrenerek izliyor ve öğrenmeye çalışıyorum. Çok teşekkür ederim.
Saygılarımla

 

[Haluk]

Teşekkürler Tevfik Bey,

Google Sheets'in ilgi görmesine sevindim...

Kod anlatılmaz, yazılır...

Google Sheets ve scripting için Türkçe kaynak... bazı özel konularda Excel VBA örnekleri

excelhaluk.blogspot.com

.