bir hüceredeki virgüllü kelimeleri yeni satır yapma

osmanoca · 10 Ağustos 2017

merhaba çok çok acil yardım lazım. lütfen bilen mesaj atsın.
sözlük dosyam var. a ve b sütunları. a sütunu bir kelime b sütununda ise çok anlamlar var. bu anlamları yeni satırlara çevirmek istiyorum. kelime satırı da yanında a sütununda olacak tabi. yani aynı kelime için kaç anlam varsa o kadar satır oluşacak. sözlükte 50000den fazla madde var.

örnek:
kitap a, b, c, d, e

olması gereken:

kitap a
kitap b
kitap c
kitap d
kitap e

çok acil lütfen....allah razı olsun...

Murat OSMA · 10 Ağustos 2017

Verileriniz A1 hücresinden itibaren alt alta ise bu kodları kullanabilirsiniz.

Kod:

[SIZE="2"]DefLng I, N, S
Sub Emre()
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        ayır = Split(Cells(i, 1).Value, ",")
        For n = 0 To UBound(ayır)
            s = s + 1
            Cells(s, 2) = IIf(n = 0, Trim(ayır(n)), Split(ayır(0), " ")(0) & Trim(ayır(n)))
        Next n
    Next i
    s = Empty: n = Empty: i = Empty: Erase ayır
End Sub[/SIZE]

Not: Eğer Öğretmen iseniz Türkçe yazım kurallarına dikkat etmenizi rica ediyorum.

osmanoca · 10 Ağustos 2017

sözlük içindir

veriler altalta değil. sözlük olduğu için a sütunuile beraber aktarması lazım.
verdiğiniz kod, anlamları ayırıyor ama soldaki kelime yanlarına koymuyor. bu nedenle sorunum devam ediyor. lütfen a sütunuyla beraber aktaracak bir şey lazım.

Murat OSMA' Alıntı:
Verileriniz A1 hücresinden itibaren alt alta ise bu kodları kullanabilirsiniz.

Kod:

[SIZE="2"]DefLng I, N, S Sub Emre() For i = 1 To Cells(Rows.Count, "A").End(3).Row ayır = Split(Cells(i, 1).Value, ",") For n = 0 To UBound(ayır) s = s + 1 Cells(s, 2) = IIf(n = 0, Trim(ayır(n)), Split(ayır(0), " ")(0) & Trim(ayır(n))) Next n Next i s = Empty: n = Empty: i = Empty: Erase ayır End Sub[/SIZE]

Not: Eğer Öğretmen iseniz Türkçe yazım kurallarına dikkat etmenizi rica ediyorum.

hmtstc · 10 Ağustos 2017

merhaba,

Aşağıdaki kodu kullanabilirsiniz. Ancak şuna dikkat edin,

1. önce dosyanızın yedeğini alın
2. yedek aldığınız dosyada aşağıdaki kodu çalıştırın
3. eski listenizin olduğu sayfada kelimelerin son anlamları kalmış olacak.
4. "YENİ SÖZLÜK" diye bir sayfada kelimeler ayrılmış olacak ancak ilk kelimenin ilk anlamı kayboluyor. Onu elle yazmanız gerekecek.

Acil dediğiniz için bu kadar yapabildim.

Dim kacıncı As Integer
Dim anlam2 As String
Dim anlam3 As String
Sub ayır2()
Application.ScreenUpdating = False
Dim i As Integer
ActiveSheet.Select
anasayfaadı = ActiveSheet.Name
sonsatır = Cells(Rows.Count, "A").End(3).Row

Sheets.Add.Name = "YENİ SÖZLÜK"
Sheets(anasayfaadı).Select
For i = 1 To sonsatır
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK").Cells(k, 2) = anlam2
'SAĞDAN(SOLDAN(A2;UZUNLUK(A2)-3);200)
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Next i
End Sub

osmanoca · 10 Ağustos 2017

overflow hatası

yeni sözlük sayfası açtı ama overflow hatası çıktı. o sayfa oluştuktan sonra tekrar deneyince bu sefer yeni boş sheetler oluşturuyor ve 400 hatası çıkıyor.

hmtstc' Alıntı:
merhaba,

Aşağıdaki kodu kullanabilirsiniz. Ancak şuna dikkat edin,

1. önce dosyanızın yedeğini alın
2. yedek aldığınız dosyada aşağıdaki kodu çalıştırın
3. eski listenizin olduğu sayfada kelimelerin son anlamları kalmış olacak.
4. "YENİ SÖZLÜK" diye bir sayfada kelimeler ayrılmış olacak ancak ilk kelimenin ilk anlamı kayboluyor. Onu elle yazmanız gerekecek.

Acil dediğiniz için bu kadar yapabildim.

hmtstc · 10 Ağustos 2017

Bunu şu sebeple yapıyor. 1 defa YENİ SÖZLÜK sayfası oluşturuyor ve tekrar oluşturmaya izin vermiyor.

Overflow hatasının nedeni satır sayısı yetersiz kalması nedeniyle bu hatayı veriyor diye tahmin ediyorum..

Programda biraz düzeltme yaptım. Yine yedek alarak çalışın tabiki.
Bu defasında hepsini verir ancak dediğim gibi satır problemi yaşanırsa ne yaparım bir bakayım siz bunu deneyin o esnada.

Dim kacıncı As Integer
Dim anlam2 As String
Dim anlam3 As String
Sub ayır2()
Application.ScreenUpdating = False
Dim i As Integer
ActiveSheet.Select
anasayfaadı = ActiveSheet.Name
sonsatır = Cells(Rows.Count, "A").End(3).Row

On Error GoTo 200
Sheets.Add.Name = "YENİ SÖZLÜK"
Sheets(anasayfaadı).Select
On Error GoTo 300
For i = 1 To sonsatır
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
Sheets(anasayfaadı).Select
Cells.Delete
MsgBox "İşlem Tamamlandı", vbInformation, " Aktarma İşlemi"
Exit Sub

200 MsgBox "YENİ SÖZLÜK SAYFASINI SİLİP TEKRAR DENEYİNİZ", vbInformation, "UYARI"
Exit Sub
300 MsgBox "Hata tanımı için hangi satırda hata verdiğini inceleyiniz."

End Sub

hmtstc · 10 Ağustos 2017

Yeni bir düzenleme yaptım. Tekrar düzeltme yapılacaktır.

hmtstc · 10 Ağustos 2017

yeni sözlüğü 5 sayfaya böldüm. Her sayfada 10000 kelime olacak. Anlamları her birinin 5 tane olsa 50000 satır yapar bu da yeter.

Başka bir hata alırsanız dosyayı paylaşmanızı rica edeceğim.

Dim kacıncı As Integer
Dim anlam2 As String
Dim anlam3 As String
Sub ayır2()
Application.ScreenUpdating = False
Dim i As Integer
ActiveSheet.Select
anasayfaadı = ActiveSheet.Name
sonsatır = Cells(Rows.Count, "A").End(3).Row

Sheets.Add.Name = "YENİ SÖZLÜK"
Sheets(anasayfaadı).Select
'
For i = 1 To 10000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
'
Sheets.Add.Name = "YENİ SÖZLÜK2"
Sheets(anasayfaadı).Select
'
For i = 10001 To 20000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK2").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK2").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK2").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
'
Sheets.Add.Name = "YENİ SÖZLÜK3"
Sheets(anasayfaadı).Select
'
For i = 20001 To 30000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK3").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK3").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK3").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
'
Sheets.Add.Name = "YENİ SÖZLÜK4"
Sheets(anasayfaadı).Select
'
For i = 30001 To 40000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK4").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK4").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK4").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
'
Sheets.Add.Name = "YENİ SÖZLÜK5"
Sheets(anasayfaadı).Select
'
For i = 40001 To sonsatır
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK5").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK5").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK5").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
'
Sheets(anasayfaadı).Select
Cells.Delete
MsgBox "İşlem Tamamlandı", vbInformation, " Aktarma İşlemi"
Exit Sub
End Sub

osmanoca · 10 Ağustos 2017

Yine sadece tek sütun kelimeler

hocam malesef yine olmadı. kod çalıştı, bir iki dakika sonra yeni sözlük sayfasına tek sütun yaptı ama bana sol sütundaki kelimeleri de lazım. çünkü bu sıralananlar anlamlar ve bunların kelimeleri de oraya aktarılmalı. bunda olmadı.

a sütunundaki kelimeler sabit kalacak karşındaki b sütunundaki çok kelimeler yine aynı kelime ile karşılıklı olarak alt alta sıralayacak.

b sütunu tamam ama a sütununu da onlarda alması lazım. biraz daha yardım değerli hocam. iki gündür bunu bulmaya çalışıyorum. kafayı yiyeceğim.

hmtstc · 10 Ağustos 2017

hocam dosyayı görüp inceleyebilmem lazım. Görmediğim hatayı düzeltemiyorum o kadar profesyonel değilim malesef. Dosyayı yükleyebilirseniz yardımcı olayım. Ya da aldığınız hata satırını yazın buraya ki hata nerde çıkıyor görelim

hmtstc · 10 Ağustos 2017

Bunu da dener misiniz hocam,

Dim kacıncı As Integer
Dim anlam2 As String
Dim anlam3 As String
Sub ayır2()
Application.ScreenUpdating = False
Dim i As Integer
ActiveSheet.Select
anasayfaadı = ActiveSheet.Name
sonsatır = Cells(Rows.Count, "A").End(3).Row

Sheets.Add.Name = "YENİ SÖZLÜK"
Sheets(anasayfaadı).Select
'
For i = 1 To 10000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
Sheets(anasayfaadı).Select
Range(Cells(1, 1), Cells(10000, 2)).Select
Selection.ClearContents
'
Sheets.Add.Name = "YENİ SÖZLÜK2"
Sheets(anasayfaadı).Select
'
For i = 10001 To 20000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK2").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK2").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK2").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
Sheets(anasayfaadı).Select
Range(Cells(10001, 1), Cells(20000, 2)).Select
Selection.ClearContents
'
Sheets.Add.Name = "YENİ SÖZLÜK3"
Sheets(anasayfaadı).Select
'
For i = 20001 To 30000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK3").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK3").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK3").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
Sheets(anasayfaadı).Select
Range(Cells(20001, 1), Cells(30000, 2)).Select
Selection.ClearContents
'
Sheets.Add.Name = "YENİ SÖZLÜK4"
Sheets(anasayfaadı).Select
'
For i = 30001 To 40000
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK4").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK4").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK4").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
Sheets(anasayfaadı).Select
Range(Cells(30001, 1), Cells(40000, 2)).Select
Selection.ClearContents
'
Sheets.Add.Name = "YENİ SÖZLÜK5"
Sheets(anasayfaadı).Select
'
For i = 40001 To sonsatır
Sheets(anasayfaadı).Select
virgülsay = Len(Cells(i, 2)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 2), ",", ""))
For j = 1 To virgülsay
kelime = Cells(i, 1)
alan = Sheets(anasayfaadı).Cells(i, 2)
kacıncı = Application.WorksheetFunction.Search(",", alan, 1)
Sheets("YENİ SÖZLÜK5").Select
sonsatır2 = Cells(Rows.Count, "A").End(xlUp).Row
k = sonsatır2 + 1
Cells(k, 1) = kelime
anlam1 = Sheets(anasayfaadı).Cells(i, 2)
anlam2 = Left(anlam1, kacıncı)
Sheets("YENİ SÖZLÜK5").Cells(k, 2) = anlam2
anlam3 = Sheets(anasayfaadı).Cells(i, 2)
sayı = Len(anlam3) - kacıncı
yenisi = Right(anlam3, sayı)
Sheets(anasayfaadı).Select
Cells(i, 2) = yenisi
Next j
Sheets(anasayfaadı).Select
sonuncu = Cells(i, 2)
Sheets("YENİ SÖZLÜK5").Select
sonsatır3 = Cells(Rows.Count, "A").End(xlUp).Row
Cells(sonsatır3 + 1, 1) = kelime
Cells(sonsatır3 + 1, 2) = sonuncu
Next i
Sheets(anasayfaadı).Select
Range(Cells(40001, 1), Cells(sonsatır, 2)).Select
Selection.ClearContents
'
Sheets(anasayfaadı).Select
Cells.Delete
MsgBox "İşlem Tamamlandı", vbInformation, " Aktarma İşlemi"
Exit Sub
End Sub

osmanoca · 10 Ağustos 2017

dosya örneğini mesajla gönderdim

bir zahmet mesajdaki örneğe bakın