• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

yanyana olan sütunları alt alta bir sütunda nasıl birleştiririm

Kodlamayı yenide yapmak, kod üzerinde değişiklik yapmaktan daha kolaydır.
Bu yüzden birşeyler istendiğinde net olarak istenmeli, yapıldıkça şuda olsun bu da olsun deyince yapılanlar çöp olabiliyor.

Benim ilk yazdığım birleştirme kodu çöp olmadı diğer isteklerinizde kulladım. Olsaydı ben de devamını getirmezdim : )
Ekli kodlar mavi ve sarı başlıklara göre çalışır, A ve B kolonlarını birleştirme için kullanır.
Mavi ve Sarı olarak iki ayrı sayfa oluşturur ve bu sayfalarda isimleri teke düşürür.

http://s2.dosya.tc/server2/qrjrjb/benzersizlistele.zip.html
 
asri' Alıntı:
Kodlamayı yenide yapmak, kod üzerinde değişiklik yapmaktan daha kolaydır.
Bu yüzden birşeyler istendiğinde net olarak istenmeli, yapıldıkça şuda olsun bu da olsun deyince yapılanlar çöp olabiliyor.

Benim ilk yazdığım birleştirme kodu çöp olmadı diğer isteklerinizde kulladım. Olsaydı ben de devamını getirmezdim : )
Ekli kodlar mavi ve sarı başlıklara göre çalışır, A ve B kolonlarını birleştirme için kullanır.
Mavi ve Sarı olarak iki ayrı sayfa oluşturur ve bu sayfalarda isimleri teke düşürür.

http://s2.dosya.tc/server2/qrjrjb/benzersizlistele.zip.html
Genişletmek için tıkla ...

çok teşekkürler, Asri Bey
yalnız örnek dosyada ben de denedim.
Şöyle iki küçük hata var.
1) Asıl listedeki sütunları birleştirmek için sayfa2 ye taşıyor... Taşımasa da kopyalasa olur mu?
2) sarı sayfada ; ile ayırmalarda ; den sonra boşlukları da alıyor.
alınan verilerin başındaki boşluklar olmasın, bu durumda veri aynı bile olsa başında boşluk olanı başka veri olmayanı başka veri olarak algılıyor

çok teşekkürler
 
Sayfa2 sadece yedek bir sayfa. Herhangi bir islem yapilmiyor.

Her ismin basinda ve sonunda bosluk silme islemi yapilabilir. Yarin bakarim.
 
Dosyadaki kodu aşağıdaki şekilde günceleyiniz.

* Tüm boşlukları tek boşluk yapar
* Hücre başındaki ve sonundaki boşlukları siler
* A-Z sıralama yapar.

Kod: 
Sub menu()
   Call sayfa_sil
   Call mavi_sari_birlestir
   Call birlesenleri_tasi
   Call virgul_ayir
   Call atli_ayir
   Call noktalivirgul_ayir
   Call son_duzenleme
End Sub

Sub sayfa_sil()
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("Mavi").Delete
  Sheets("Sari").Delete
  Application.DisplayAlerts = True
End Sub

Sub mavi_sari_birlestir()
 sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 For i = sonsutun To 3 Step -1
    sonsatir = Cells(Rows.Count, i).End(3).Row
    If sonsatir = 1 Then GoTo son
    'Sari
    If Cells(1, i).Interior.Color = 65535 Then
       asonsatir = Cells(Rows.Count, "A").End(3).Row + 1
       Range(Cells(2, i), Cells(sonsatir, i)).Select
       Selection.Cut
       Cells(asonsatir, 1).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False
    End If
    
    'mavi
    If Cells(1, i).Interior.Color = 15123099 Then
       asonsatir = Cells(Rows.Count, "B").End(3).Row + 1
       Range(Cells(2, i), Cells(sonsatir, i)).Select
       Selection.Cut
       Cells(asonsatir, 2).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False
    End If
son:
  Next i
End Sub

Sub normal_birlestir()
 sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 For i = sonsutun To 2 Step -1
    sonsatir = Cells(Rows.Count, i).End(3).Row
    If sonsatir = 1 Then GoTo son
       asonsatir = Cells(Rows.Count, "A").End(3).Row + 1
       Range(Cells(2, i), Cells(sonsatir, i)).Select
       Selection.Cut
       Cells(asonsatir, 1).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False
son:
  Next i
End Sub

Sub birlesenleri_tasi()
    Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
    NewSh.Name = "Mavi"
    Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
    NewSh.Name = "Sari"
    Sheets("FilmListesi").Select
    Columns("B:B").Select
    Selection.Cut
    Sheets("Mavi").Select
    ActiveSheet.Paste
    Sheets("FilmListesi").Select
    Columns("A:A").Select
    Selection.Cut
    Sheets("Sari").Select
    ActiveSheet.Paste
End Sub

Sub virgul_ayir()
  Sheets("Sari").Select
  sonsatir = Cells(Rows.Count, 1).End(3).Row
  If sonsatir <= 2 Then Exit Sub
  
  Columns("A:A").Select
  Range("A1").Activate
  Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
     Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
     :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
  Call normal_birlestir
  sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
  kolon = "$A$1:$A$" & sonsatir
  ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
  Range("A3").Select
End Sub

Sub atli_ayir()
    Sheets("Mavi").Select
    sonsatir = Cells(Rows.Count, 1).End(3).Row
    If sonsatir <= 2 Then Exit Sub
    Columns("A:A").Select
    Range("A1").Activate
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="@", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    Range("B1").Select
    Call normal_birlestir
    
End Sub

Sub noktalivirgul_ayir()
    Sheets("Mavi").Select
    sonsatir = Cells(Rows.Count, 1).End(3).Row
    If sonsatir <= 2 Then Exit Sub
    Columns("A:A").Select
    Range("A1").Activate
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, OtherChar _
        :="@", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Columns("B:XFD").Select
    Selection.ClearContents
    Range("A1").Select
    Selection.End(xlUp).Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    kolon = "$A$1:$A$" & sonsatir
    ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
    Range("A3").Select
    
End Sub


Sub son_duzenleme()
    Sheets("Mavi").Select
    Columns("A:A").EntireColumn.AutoFit
    Sheets("Sari").Select
    Columns("A:A").EntireColumn.AutoFit
    Columns("A:A").Select
    
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    kolon = "$A$1:$A$" & sonsatir
    ActiveSheet.Range(kolon).Select
    Call bosluklari_sil
    
    ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
    
    ActiveWorkbook.Worksheets("Sari").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sari").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sari").Sort
        .SetRange Columns("A:A")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A7").Select
    Sheets("Mavi").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    kolon = "$A$1:$A$" & sonsatir
    ActiveSheet.Range(kolon).Select
    Call bosluklari_sil
    
    ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
    
    Columns("A:A").Select
    ActiveWorkbook.Worksheets("Mavi").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Mavi").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Mavi").Sort
        .SetRange Columns("A:A")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A6").Select
End Sub

Public Function tek_bosluk(cumle)
  gecici = ""
  eski = "99"
  If InStr(1, cumle, " ") > 0 Then
    For i = 1 To Len(cumle)
      h = Mid(cumle, i, 1)
      If eski <> " " Then
        gecici = gecici + h
      ElseIf eski = " " And h <> " " Then
        gecici = gecici + h
      End If
      eski = h
    Next i
    If gecici <> "" Then gecici = WorksheetFunction.Trim(gecici)
    tek_bosluk = gecici
    
  Else
     If cumle <> "" Then gecici = WorksheetFunction.Trim(cumle)
     tek_bosluk = gecici
  End If

End Function

Sub bosluklari_sil()
  For Each hucre In Selection
    If hucre <> Empty Then hucre.Value = tek_bosluk(hucre)
  Next
End Sub
 
meleklerim' Alıntı:
teşekkürler asri bey,
artık boşluklar yok,
sarı sütunlarda 6936 veri buldu, gayet güzel elinize sağlık
fakat bu seferde mavi sütunlara hiç dokunmuyor.
örnek dosyayı ekledim.
bir incelerseniz sevinirim.

http://s2.dosya.tc/server2/lfbxys/benzersizlistele2.rar.html
Genişletmek için tıkla ...

Dosyanın formatını değiştirmişsiniz.

Sarı olan alan sarı, mavi olan ise mavi sıradaki alttan 3. mavi olmalı.

Renkler benim gönderdiğim dosyadak gibi olmalı.
 
tamam Asri Bey, renk kodlarını değiştirince mavilerde de çalışmaya başladı. Mükemmel ötesi...
Yalnız korktuğum başıma geldi, 1.041.101. satırda active.shett paste hatası verdi :)
mavi veriler devasa olduğundan bir sayfanın satır sayısı yetmedi.
H sütunundaki verileri mavi grupta, U;AH sütunlarındaki verileri de başka bir renkle kodlasanız,
çözüm olur mu ki???
 
meleklerim' Alıntı:
tamam Asri Bey, renk kodlarını değiştirince mavilerde de çalışmaya başladı. Mükemmel ötesi...
Yalnız korktuğum başıma geldi, 1.041.101. satırda active.shett paste hatası verdi :)
mavi veriler devasa olduğundan bir sayfanın satır sayısı yetmedi.
H sütunundaki verileri mavi grupta, U;AH sütunlarındaki verileri de başka bir renkle kodlasanız,
çözüm olur mu ki???
Genişletmek için tıkla ...

Deneme amaçlı,
D den itibaren tüm sütunları tek tek seçip, başlık satırı var diyerek sıralayın.
Bu işlem satırlar arası boşlukları kaldıracaktır.

Daha sonra programı çalıştırın. Bakalım ne yapacak.
 
Sadece H sütunu bile yetmedi Asri Bey, bilginize.
Bu H sütununu tek başına farklı ele almak lazım galiba. (sığmayınca diğer sayfaya geç gibi)
 
meleklerim' Alıntı:
Sadece H sütunu bile yetmedi Asri Bey, bilginize.
Bu H sütununu tek başına farklı ele almak lazım galiba. (sığmayınca diğer sayfaya geç gibi)
Genişletmek için tıkla ...

Programlama mantığını değiştirmem gerekecek.
Dizi değişkenler kullanarak birleştirme ve parçamala işlemleri yaptıktan sonra 1 er milyon satırı aşmayacak şekilde sayfalara yazdırmam gerekecek.

Hafta sonu bakabilirim.
Acil ise H sütununu çıkarıp işlemleri yapın.
Daha sonra H sütünunu 40.000 satırı geçmeyecek şekilde başka bir sayfada parçalara bölüp film sayfasına parça parça ekleyerek işlemleri yaptırabilirsiniz.
 
asri' Alıntı:
Deneme amaçlı,
D den itibaren tüm sütunları tek tek seçip, başlık satırı var diyerek sıralayın.
Bu işlem satırlar arası boşlukları kaldıracaktır.

Daha sonra programı çalıştırın. Bakalım ne yapacak.
Genişletmek için tıkla ...


sıralamak da işe yaramadı,
bu sefer hata vermeden tamamladı ama sarı sayfada 2 bin civarında (6-8 bin civarında olması gerekiyor)
mavi sayfada ise çözümlenmemiş 16 bin civarında veri buldu.

Toplamda (mavi-sarı sayfa birleşik ve benzersiz 32. bin civarında bulması gerekiyor, tam olarak 32.082)

Son belgeyi (sıralanmış) ekte upload ettim. Makroyu bir de siz çalıştırısanız hatanın sebebini siz daha iyi bilirsiniz.

Hafta sonuna kadar acil bir durumu yok. Size de zahmet verdim.
emekleriniz ödenmez.

http://dosya.co/dlrikdbhggjw/benzersizlistele3.rar.html
 
Dosyanızın AS63876 hücresinde aşağıya doğru ve sağa doğru büyük miktarda veri var.
Herhangi bir renge bağlanmamış, orada unutulmuş gibi : )

Bu veri hangi renge ait. Kullanılacak mı silinecek mi?
 
meleklerim' Alıntı:
sıralamak da işe yaramadı,
bu sefer hata vermeden tamamladı ama sarı sayfada 2 bin civarında (6-8 bin civarında olması gerekiyor)
mavi sayfada ise çözümlenmemiş 16 bin civarında veri buldu.

Toplamda (mavi-sarı sayfa birleşik ve benzersiz 32. bin civarında bulması gerekiyor, tam olarak 32.082)

Son belgeyi (sıralanmış) ekte upload ettim. Makroyu bir de siz çalıştırısanız hatanın sebebini siz daha iyi bilirsiniz.

Hafta sonuna kadar acil bir durumu yok. Size de zahmet verdim.
emekleriniz ödenmez.

http://dosya.co/dlrikdbhggjw/benzersizlistele3.rar.html
Genişletmek için tıkla ...

Her parçalama dan sonra ve birşleştirmeden önce sıralama eklendi.
1 milyon satır problemi olmadı.

mavi ve sarı tekil toplamı 34176 oldu.

Kontrol ediniz.


http://s4.dosya.tc/server2/ettayv/benzersizlistele_v2.zip.html
 
asri' Alıntı:
Her parçalama dan sonra ve birşleştirmeden önce sıralama eklendi.
1 milyon satır problemi olmadı.

mavi ve sarı tekil toplamı 34176 oldu.

Kontrol ediniz.


http://s4.dosya.tc/server2/ettayv/benzersizlistele_v2.zip.html
Genişletmek için tıkla ...

büyük sürpriz, makroyu hemen deniyorum
34176 olmasının sebebi mavi+sarı sayfayların toplamıdır.
o iki sayfadaki veriler de benzersiz olarak sıralananınca sanırım 2 bin eksilir.
İkisinin (mavi+sarı) benzersiz olacağı bir makro ekli değil sanırım.

Dosyanın adı gibi benzersiz bir işlem yapıyor yaptığınız kodlar.
Siz de benzersizsiniz :)
Bursa civarına gelirseniz sizi ağırlamak isterim. bir telefon yeterlidir.
selamlar
 
mavi+sarıyı
benzersiz sıralayınca tam 32.082yi verdi.
önceden 5-6 makroyla ve nerdeyse 1 saate olan iş tek makro ve 3 dk da halloldu.
tekrar teşekkürler
 
Son düzenleme:
son tahlilde mavi ve sarıyı benzersiz olarak bir sayfa ya da sütunda birleştirse... desem
çok mu şey istemiş olurum?
Normalde başka bir makro ile yapılabilir ama ben tek makroda olsun tümleşik olursa hata oranı olmaz diye istiyorum
 
sonuc_birlestir kodu eklendi.
Dosyanızdaki kodları silerek, aşağıdaki kodları ekleyiniz.

Kod: 
Dim sonsatir, asonsatir As Long

Sub menu()
   Application.ScreenUpdating = False
   Call sayfa_sil
   Call mavi_sari_birlestir
   Call birlesenleri_tasi
   Call virgul_ayir
   Call atli_ayir
   Call noktalivirgul_ayir
   Call son_duzenleme
   Call sonuc_birlestir
   Application.ScreenUpdating = True
   MsgBox ("İşlem Tamamlandı")
End Sub

Sub sayfa_sil()
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("Mavi").Delete
  Sheets("Sari").Delete
  Sheets("MaviSari").Delete
  Application.DisplayAlerts = True
End Sub

Sub mavi_sari_birlestir()
 sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 For i = sonsutun To 3 Step -1
    sonsatir = Cells(Rows.Count, i).End(3).Row
    Range(Cells(2, i), Cells(sonsatir, i)).Select
    Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, Header:=xlGuess
    sonsatir = Cells(Rows.Count, i).End(3).Row
    
    If sonsatir = 1 Then GoTo son
    'Sari
    If Cells(1, i).Interior.Color = 65535 Then
       asonsatir = Cells(Rows.Count, "A").End(3).Row + 1
       Range(Cells(2, i), Cells(sonsatir, i)).Select
       Selection.Cut
       Cells(asonsatir, 1).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False
    End If
    
    'mavi
    If Cells(1, i).Interior.Color = 15123099 Then
       asonsatir = Cells(Rows.Count, "B").End(3).Row + 1
       Range(Cells(2, i), Cells(sonsatir, i)).Select
       Selection.Cut
       Cells(asonsatir, 2).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False
    End If
son:
  Next i
End Sub

Sub normal_birlestir()
 sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 For i = sonsutun To 2 Step -1
    Columns(i).Select
    Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, Header:=xlGuess
    sonsatir = Cells(Rows.Count, i).End(3).Row
    If sonsatir = 1 And Cells(1, i).Value = "" Then GoTo son
       asonsatir = Cells(Rows.Count, "A").End(3).Row + 1
       Range(Cells(1, i), Cells(sonsatir, i)).Select
       Selection.Cut
       Cells(asonsatir, 1).Select
       ActiveSheet.Paste
       Application.CutCopyMode = False
son:
  Next i
End Sub

Sub birlesenleri_tasi()
    Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
    NewSh.Name = "MaviSari"
    Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
    NewSh.Name = "Mavi"
    Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
    NewSh.Name = "Sari"
    Sheets("FilmListesi").Select
    Columns("B:B").Select
    Selection.Cut
    Sheets("Mavi").Select
    ActiveSheet.Paste
    Sheets("FilmListesi").Select
    Columns("A:A").Select
    Selection.Cut
    Sheets("Sari").Select
    ActiveSheet.Paste
End Sub

Sub virgul_ayir()
  Sheets("Sari").Select
  sonsatir = Cells(Rows.Count, 1).End(3).Row
  If sonsatir <= 2 Then Exit Sub
  
  Columns("A:A").Select
  Range("A1").Activate
  Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
     Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
     :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
  Call normal_birlestir
  sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
  kolon = "$A$1:$A$" & sonsatir
  ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
  Range("A3").Select
End Sub

Sub atli_ayir()
    Sheets("Mavi").Select
    sonsatir = Cells(Rows.Count, 1).End(3).Row
    If sonsatir <= 2 Then Exit Sub
    Columns("A:A").Select
    Range("A1").Activate
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="@", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    Range("B1").Select
    Call normal_birlestir
    
End Sub

Sub noktalivirgul_ayir()
    Sheets("Mavi").Select
    sonsatir = Cells(Rows.Count, 1).End(3).Row
    If sonsatir <= 2 Then Exit Sub
    Columns("A:A").Select
    Range("A1").Activate
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, OtherChar _
        :="@", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Columns("B:XFD").Select
    Selection.ClearContents
    Range("A1").Select
    Selection.End(xlUp).Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    kolon = "$A$1:$A$" & sonsatir
    ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
    Range("A3").Select
    
End Sub


Sub son_duzenleme()
    Sheets("Mavi").Select
    Columns("A:A").EntireColumn.AutoFit
    Sheets("Sari").Select
    Columns("A:A").EntireColumn.AutoFit
    Columns("A:A").Select
    
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    kolon = "$A$1:$A$" & sonsatir
    ActiveSheet.Range(kolon).Select
    Call bosluklari_sil
    
    ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
    
    ActiveWorkbook.Worksheets("Sari").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sari").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sari").Sort
        .SetRange Columns("A:A")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A7").Select
    Sheets("Mavi").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    kolon = "$A$1:$A$" & sonsatir
    ActiveSheet.Range(kolon).Select
    Call bosluklari_sil
    
    ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:=xlYes
    
    Columns("A:A").Select
    ActiveWorkbook.Worksheets("Mavi").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Mavi").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Mavi").Sort
        .SetRange Columns("A:A")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A6").Select
End Sub

Public Function tek_bosluk(cumle)
  gecici = ""
  eski = "99"
  If InStr(1, cumle, " ") > 0 Then
    For i = 1 To Len(cumle)
      h = Mid(cumle, i, 1)
      If eski <> " " Then
        gecici = gecici + h
      ElseIf eski = " " And h <> " " Then
        gecici = gecici + h
      End If
      eski = h
    Next i
    If gecici <> "" Then gecici = WorksheetFunction.Trim(gecici)
    tek_bosluk = gecici
    
  Else
     If cumle <> "" Then gecici = WorksheetFunction.Trim(cumle)
     tek_bosluk = gecici
  End If

End Function

Sub bosluklari_sil()
  For Each hucre In Selection
    If hucre <> Empty Then hucre.Value = tek_bosluk(hucre)
  Next
End Sub

Sub sonuc_birlestir()
    Sheets("Mavi").Select
    Range("A1").Select
    sonsatir = Cells(Rows.Count, 1).End(3).Row
    Range(Cells(1, 1), Cells(sonsatir, 1)).Select
    Selection.Copy
    Sheets("MaviSari").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    
    Sheets("Sari").Select
    Range("A1").Select
    sonsatir = Cells(Rows.Count, 1).End(3).Row
    Range(Cells(1, 1), Cells(sonsatir, 1)).Select
    Selection.Copy
    Sheets("MaviSari").Select
    Range("A1").Select
    Selection.Insert Shift:=xlDown
    Columns("A:A").EntireColumn.AutoFit
    Columns("A:A").Select
    Application.CutCopyMode = False
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    kolon = "$A$1:$A$" & sonsatir
    ActiveSheet.Range(kolon).RemoveDuplicates Columns:=1, Header:= _
        xlNo
    Range("A1").Select

End Sub
 
budur... :)

süper ötesi oldu.
elinize emeğinize sağlık
 
merhabalar benimde tam bunun tersi bir sorunum vardi alt alta olan verileri makro ile yan sayfaya yan yana sıralama
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst