Excel'e alfabetik kayıt

[VeliDemir]

Merhaba. Öncellikle böyle bir hizmeti sunduğunuzdan ötürü sizlere teşekkür ederim. Ben sizlerden şöyle bir makro programı rica ediyorum. Bu makro programın, benden aldığı kelimeleri ilk harflerine göre bir Excel dosyasının A-Z sütunlarına sırayla kelime tekrarı yapmadan yazmasını istiyorum.

İyi akşamlar

 

[ÖmerBey]

Merhaba,
Bahsettiğiniz bu program sizden kelimeleri nasıl alacak acaba?
Kelimelerin sayısı kaç olacak, A-Z'ye sığmazsa ne yapacak?
gibi cevabını bilemeyeceğim sorular aklıma geliyor. Üzerinde açıklama yaptığınız bir örnek dosya paylaşsaydınız ne yapmak istediğinizi anlamamız daha kolay olurdu...

 

[VeliDemir]

Merhaba. Bu makro program benden kelimeleri yazma kutusuyla alacak. Bu kelimelerin toplam sayısı ise 2000'i geçmiyor ve bazı kelimelerde mükerrerlik vardır. Bu kelimeleri programın yazma kutusuna teker teker elle yazmayı ve daha sonra kutudaki düğmeye basarak A-Z sütunlarına sırayla mükerrerliğe mahal vermeden aktarılmasını istiyorum. Şöyle bir örnekle açıklamak gerekirse;

Mesela, program kutusuna "sevmek" yazdım ve düğmeye basdım. Sonra kutuya "Sarı" yazdım ve düğmeye bastım. "Sevmek" ve "Sarı" kelimeleri alfabetik sıraya göre S sütunundaki ilgili satırlara yazılacak. Eğer "Sevmek" veya "Sarı" kelimelerini bir daha kutuya yazarak düğmeye basarsam herhangi bir işlem yapılmayacak.

 

[ÖmerBey]

Tekrar merhaba,
Aşağıdaki kodu deneyiniz. İptal tuşuna basana kadar kelime sorar.

Sub Kod()
Do
    kelime = Application.InputBox("Kelimeyi giriniz.")
    If kelime = False Then
        Exit Sub
    Else
        süt = Left(kelime, 1)
        If WorksheetFunction.CountIf(Columns(süt), kelime) = 0 Then
            Cells(Rows.Count, süt).End(3).Offset(1) = kelime
            Columns(süt).Sort Cells(1, süt), xlAscending
        End If
    End If
Loop
End Sub

 

[VeliDemir]

Merhaba. Öncellikle bu yardımınızdan ötürü size teşekkür ederim.
kelime = Application.InputBox("Kelimeyi giriniz.") kısmında makro programı hata veriyor bu kısmı düzeltebilir misiniz?

 

[ÖmerBey]

Ne tür bir hata olduğunu belirtseydiniz...
Bir de şu şekilde deneyiniz.

Sub Kod()
Do
    kelime = InputBox("Kelimeyi giriniz.")
    If kelime = False Or kelime = "" Then
        Exit Sub
    Else
        süt = Left(kelime, 1)
        If WorksheetFunction.CountIf(Columns(süt), kelime) = 0 Then
            Cells(Rows.Count, süt).End(3).Offset(1) = kelime
            Columns(süt).Sort Cells(1, süt), xlAscending
        End If
    End If
Loop
End Sub

 

[VeliDemir]

Merhaba. Program bu kez If WorksheetFunction.CountIf(Columns(süt), kelime) = 0 Then satırında "Alt yöntem veya işlev yöntemi tanımlanmadı" diye uyarı mesajı vererek çalışmıyor.Sizi yorduğumun farkındayım, ama bu hususu düzeltmenizi sizden rica ediyorum.

 

[ÖmerBey]

Microsoft Excel dışında bir program kullanıyor olabilir misiniz acaba?
LibreOffice gibi...
Çünkü öyleyse yapacağım bir şey yok... Ne yazık ki; onların kod yapısını bilmiyorum.

 

[VeliDemir]

Teşekkür ederim.

 

[ÖmerBey]

Rica ederim, yardımcı olabilsek daha iyiydi ama belki konu hakkında bilgisi olan başka bir arkadaş yardımcı olabilir.
Makro kaydet ile oluşan kodlar ile LibreOffice'de şu şekilde birşey yaptım ama hatalı çalışıyor. Tam sonuca varamadım maalesef. İyi çalışmalar...

Sub Kod()
dim sut as string
dim kelime as string
Do
    kelime = InputBox("Kelimeyi giriniz.")
    If kelime = False Or kelime = "" Then
        Exit Sub
    Else
        sut = Left(kelime, 1)
        for a = 1 to 200
        	if ThisComponent.CurrentController.ActiveSheet.getCellRangeByName(sut & a).string = kelime then goto 1
        next
        
        ThisComponent.CurrentController.ActiveSheet.getCellRangeByName(sut & 1001).string = kelime

  		oCellRange = ThisComponent.CurrentController.ActiveSheet.columns.getbyname(sut)
  		ThisComponent.getCurrentController.select(oCellRange)
              
		dim document   as object
		dim dispatcher as object

		document   = ThisComponent.CurrentController.Frame
		dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")


		dispatcher.executeDispatch(document, ".uno:SortAscending", "", 0,Array())      

    End If
1    
Loop
End Sub

 

[VeliDemir]

Merhaba.

Sub Kod()
Do
kelime = InputBox("Kelimeyi giriniz.")

kodları ile başlayan makro programınız işimi büyük ölçüde gördü. Bu nedenle, çok teşekkür ederim. Ancak bu makro programı "ç, ğ, i, ö, ş, ü" harfleri ile başlayan Türkçe kelimelerde hata veriyor. Bu harflerle başlayan kelimelerin "C, G, I, O, S, U" sütunlarına atanmasına sağlayacak şekilde söz konusu makro programının iyileştirilmesini sizden rica ediyorum. İyi günler.

 

[ÖmerBey]

Merhaba,
Kodun düzenlenmiş hali aşağıdadır. İyi çalışmalar...

Sub Kod()
[COLOR="Red"]bul = Array("Ç", "Ğ", "İ", "Ö", "Ş", "Ü")
deg = Array("C", "G", "I", "O", "S", "U")[/COLOR]
Do
    kelime = InputBox("Kelimeyi giriniz.")
    If kelime = False Or kelime = "" Then
        Exit Sub
    Else
[COLOR="Red"]        süt = UCase(Left(kelime, 1))
        For a = LBound(bul) To UBound(bul)
            süt = Replace(süt, bul(a), deg(a))
        Next[/COLOR]
        
        If WorksheetFunction.CountIf(Columns(süt), kelime) = 0 Then
            Cells(Rows.Count, süt).End(3).Offset(1) = kelime
            Columns(süt).Sort Cells(1, süt), xlAscending
        End If
    End If
Loop
End Sub

 

[VeliDemir]

Teşekkür ederim.