• DİKKAT

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

Yazı dosyasındaki kelimeleri Excele aktarma

I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Sayın uzmanlarım merhaba

Diyelimki D diskimizde Excel adlı bir not belgesi var (Bildiğiniz .txt dosyası)

Ve bu not belgesinde aşağıdaki yazı var.

Microsoft Excel Nedir?
Bir hesap tablosu (spreadsheet) programıdır. Excel, her türlü veriyi (özellikle sayısal verileri) tablolar ya da listeler halinde tutma ve bu verilerle ilgili ihtiyaç duyacağınız tüm hesaplamaları ve analizleri yapma imkanı sunan bir uygulama programıdır.

Aynı zamanda, yine D diskimizde bir excel dosyamız var. Bunun ismi de Excel.xls olsun




İstediğim şu : Makro düğmesine basınca yazı dosyasındaki kelimeler yukarıdan aşağıya doğru A sütununa gelsin

Yani Excel dosyasında

A1 hücresinde Microsoft
A2 hücresinde Excel
A3 hücresinde nedir
A4 hücresinde Bir
A5 hücresinde hesap
A6 hücresinde tablosu
....
...
..

şeklinde kelimelerin hepsi, yukarıdan aşağıya gelsin

Bir minik ekleme: kelimeler arasındaki boşluk ve her türlü noktalama işaretleri gereksizdir, istenmemektedir

Selam ve saygılar uzmanlarım
 
Merhaba.

Daha iyisi yapılabilir sanırım ama, noktalama işaretleri ayıklaması yapılmadan,
sadece BOŞLUK kriterine göre listelemeisterseniz aşağıdaki gibi olabilir.

Aşağıdaki kod'u kelime listeleyeceğiniz excel sayfanın kod bölümüne yapıştırın.
(Alt taraftan sayfa adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçtiğinizde açılan ekranın sağ tarafındaki boş alan)

Ardından txt belge içeriğini KOPYALAyın ve excel sayfası B1 hücresini seçip yapıştırın.
Aşağıdaki kod'u çalıştırın.

Son olarak, (eğer A sütununda oluşan liste işinizi görecekse)
A sütununu seçip, CTRL+H ile silinmesi gereken noktalama işaretlerini silebilirsiniz.
.
Kod: 
[FONT="Arial Narrow"]Sub listele_kriter_bosluk()
Range("A:A").ClearContents: Cells(1, 1) = "KELİMELER": alan = "B1:B" & [B65536].End(3).Row
If Range("C1", ActiveCell.SpecialCells(xlLastCell)).Column > 2 Then _
Range("C1", ActiveCell.SpecialCells(xlLastCell)).ClearContents
Range(alan).TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True, Other:=False
For satır = 1 To [B65536].End(3).Row
    Range(Cells(satır, 3), Cells(satır, Cells(satır, 3).End(2).Column)).Copy
    Cells([A65536].End(3).Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
Next
Range("B1", ActiveCell.SpecialCells(xlLastCell)).ClearContents
Columns("A:A").EntireColumn.AutoFit: Cells(1, 1).Activate: MsgBox "İşlem Tamam..."
End Sub[/FONT]
 
Değerli Ömer Baran uzmanım, önce ilginize ve cevabınıza teşekkür eder saygılar sunarım

Aşağıya örnek olması açısından bir metin parçası ekliyorum

Bisikletinize düzenli bakımlar yaparak, kendiniz için daha güvenli bir sürüş sağlayabilirsiniz.Bisikletinize yapacağınız düzenli kontroller bisikletinizin ömrünü uzatabilir, bisiklet keyfinize ara vermeden devam edebilirsiniz. Bisiklet bakımında dikkat etmeniz gereken ana noktalar:
1.Bisikletinizi iyi dinleyin.
Bisikletinizden gelen pek de hoş olmayan tiz sesler, metal aksamlardan gelen çeşitli sesler ve takırtılar size bisikletinizle alakalı bir şeylerin yanlış gittiğini haber vermeye çalışıyorlar. Bu seslere kulak verin ve gerekli aksiyonu almaya özen gösterin. Aslında bisiklet bakımının altın kuralı olmasına rağmen bu kuralın ne kadar ihlal edildiğini tahmin edebiliyorsunuzdur.
2.Fren pabuçlarınızı yenileyin.
Etkili ve düzgün çalışan fren pabuçları güvenli bir bisiklet sürüşü için olmazsa olmazlardan. Fren pabuçlarınız özellikle İstanbul gibi bol inişli bir şehirde pedallıyorsanız, sürtünmeden kaynaklı sürekli erime eğilimindedirler. Pabuçlarınızın erimesi durumunda bisikletinizi durdurmak için gerekli gücü üretemezsiniz. Pabuçlarınızı değiştirmeden evvel, pabuçlarınızı biraz zımparadan geçirip, eriyen yüzeyine biraz pürüz katıp belirli bir süre daha kullanmaya devam edebilirsiniz.
3.Kadronuzu koruyun.
Vites ve fren kabloları bisiklet kadrosu üzerinden geçirilmek durumundalar. Bu kabloların bisiklet kadronuza zarar verdiğini farkettiyseniz, kabloların kadroya temas ettikleri yerleri elektrik bandı ile sarıp kadronuzu koruyabilirsiniz.
4.Lastiklerinizin havasını belirli seviyenin altına indirmeyin.
Lastiklerin havasını yeterli seviyede tutmazsanız bisikletinizin jantında eğilmelere sebebiyet verebilirsiniz. Ayrıca iç lastğinizin jantlar tarafından ezilmesi ve sonunda patlamış bir tekerle yolda kalmanız da mümkün.
5.Bisiklet zincir bakımına özen gösterin.
Zincirlerinizi arada yağlayın, dişlilerle aralarındaki sürtünmeyi azaltın ve tahribatını yavaşlatın. Bisikletinizin zincir bakımı için, ince bir makina yağı ya da bisikletlere özel yağlardan kullanabilirsiniz.
6.Selenizi arada hareket ettirin.
Selemizin yerini kendi boyumuza uygun ayarladıktan sonra ihtiyacımız olmadığı sürece pek hareket ettirmeyiz. Ama selemiz yıllarca aynı konumunda kalacak olursa istesek de bir daha hareket ettirememiz mümkün. Bu sebeple arada selenizi aşağı yukarı hareket ettirmeniz iyi olacaktır.


Örnek olarak bu metni B1 hücresine yapıştırdığımda bütün kelimeler sıralanmıyor

Acaba bu sorunu çözebilir misiniz?
 
Merhaba.

B1 hücresine yapıştırın derken kastım;
-- B1 hücresi seçiliyken formül çubuğuna veya
-- F2 tuşuyla B1 hücresinin içine girerek hücreye yapıştırmanız değil idi.

Metni seçip kopyalayın, B1 hücresi seçiliyken CTRL+V tuşuna basarak,
metnin excele aktarılmasını sağlayın ve kod'u çalıştırın.
Not: Noktalama işaretleri konusunda da birşeyler yapılabilir belki, halledersem tekrar mesaj yazarım.

Gönderdiğiniz metin için kod'u çalıştırdığımda ortaya çıkan sonuç
A1'de başlık + 272 adet hücrede oluşan liste.

Söylediğim şekilde tekrar deneyin.
.
 
Tekrar merhaba.

Bir önceki cevabıma da bakınız. Kodların kullanılmasına ilişkin açıklama yazmıştım.

Önceki verdiğim kod yerine bir de aşağıdakini (noktalama işaretlerini silmeye yönelik olarak) deneyin.
.
Kod: 
[FONT="Arial Narrow"][B][COLOR="Blue"]Sub kelime_listele()[/COLOR][/B]
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Range("A:A").ClearContents: Cells(1, 1) = "KELİMELER": alan = "B1:B" & [B65536].End(3).Row
    Range(alan).Replace What:=".", Replacement:=". ", LookAt:=xlPart, SearchOrder:=xlByRows
    Range(alan).Replace What:=".  ", Replacement:=". ", LookAt:=xlPart, SearchOrder:=xlByRows
If Range("C1", ActiveCell.SpecialCells(xlLastCell)).Column > 2 Then _
Range("C1", ActiveCell.SpecialCells(xlLastCell)).ClearContents
Range(alan).TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True, Other:=False
For brn2 = 1 To [B65536].End(3).Row
    Range(Cells(brn2, 3), Cells(brn2, Cells(brn2, 3).End(2).Column)).Copy
    Cells([A65536].End(3).Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
Next
For brn = 2 To [A65536].End(3).Row
If Asc(Right(Cells(brn, 1), 1)) = 231 Or Asc(Right(Cells(brn, 1), 1)) = 199 Or Asc(Right(Cells(brn, 1), 1)) = 221 Or _
    Asc(Right(Cells(brn, 1), 1)) = 253 Or Asc(Right(Cells(brn, 1), 1)) = 240 Or Asc(Right(Cells(brn, 1), 1)) = 208 Or _
    Asc(Right(Cells(brn, 1), 1)) = 246 Or Asc(Right(Cells(brn, 1), 1)) = 214 Or Asc(Right(Cells(brn, 1), 1)) = 252 Or _
    Asc(Right(Cells(brn, 1), 1)) = 220 Or Asc(Right(Cells(brn, 1), 1)) = 254 Or Asc(Right(Cells(brn, 1), 1)) = 222 Then GoTo 10
    For kod = 2 To 47
        Cells(brn, 1) = Left(Cells(brn, 1), Len(Cells(brn, 1)) - 1) & _
                        WorksheetFunction.Substitute(Right(Cells(brn, 1), 1), Chr(kod), "")
    Next
    For kod = 91 To 96
        Cells(brn, 1) = Left(Cells(brn, 1), Len(Cells(brn, 1)) - 1) & _
                        WorksheetFunction.Substitute(Right(Cells(brn, 1), 1), Chr(kod), "")
    Next
    For kod = 123 To 255
        Cells(brn, 1) = Left(Cells(brn, 1), Len(Cells(brn, 1)) - 1) & _
                        WorksheetFunction.Substitute(Right(Cells(brn, 1), 1), Chr(kod), "")
    Next
10: Next
Range("[B][COLOR="Red"]C1[/COLOR][/B]", ActiveCell.SpecialCells(xlLastCell)).ClearContents
Columns("A:A").EntireColumn.AutoFit: Cells(1, 1).Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem Tamam...", vbInformation, "...****... izcik ...****..."
[B][COLOR="blue"]End Sub[/COLOR][/B][/FONT]
 
Son düzenleme:
Uzmanım, B1 hücresine yapıştırma konusunda uyarınızdan sonra kodların çok güzel çalıştığını gördüm. Size helal olsun, selam ve saygılar

İkinci kodda şöyle minik bir ekleme yapabilir miyiz?

Virgülleri siliyor, acaba nokta işaretlerini de sildirebilir miyiz?

(Silinmese de çok önemli değil,

Zira CTRL+H ile bunu kolaylıkla yapabiliriz)
 
Merhaba.

Son kod'da güncelleme yaptım, noktalama işaretlerinin tümü de temizleniyor.
Gönderdiğiniz örnek metin için BAŞLIK + 279 kelimelik liste oluşuyor.

Kod'un yeni halini deneyiniz.
.
 
Siz Uzmanlarımızın sayesinde bir şeyler öğreniyoruz. Selamlarımı saygılarımı sunarım
 
Estağfurullah. Uzman yerine TECRÜBELİyi tercih ederim.

Belgede B1 hücresine yapıştırdığınız, ilk verilerin önceki kod'da olduğu gibi silinmesini istiyorsanız;
son gönderdiğim kod'un son kısmında kırmızı renklendirdiğim C1'i, B1 olarak değiştirmeniz yeterli olur.

Belki silmek istemezsiniz diye C1 yapmıştım.

İyi günler dilerim.
.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst