Açıklama kutularındakileri formülle veya başka yolla kopyalayabilirmiyim?

[endless32]

Selam Arkadaşlar

Açıklama kutusundaki verileri tek tek,aynı sayfa içerisinde başka bir yere alt alta satır olarak kopyalayabilirmiyim?Binlerce açıklama kutum olduğundan bu işlemi daha kısa yoldan yapmam gerekiyor!!

Ek'te örnek bir dosyam var,bana yardımcı olabilirmisiniz?

 

[Ömer]

Merhaba,

Module kopyalarak çalıştırınız. Açıklamalar B sütununa yazılacaktır..

Sub AciklamaMetinleri()
 
    Dim sat As Long, i As Long
 
    Range("B5:B" & Rows.Count).ClearContents
 
    sat = 5
    For i = 5 To Cells(Rows.Count, "E").End(xlUp).Row
        Cells(sat, "B") = Cells(i, "E").Comment.Text
        sat = sat + 1
    Next i
 
End Sub

.

 

[endless32]

Ömer hocam,merhaba

Öncelikle tşk.ederim.Bir sorum daha olacak?
örnek olarak; 0.9 hanesinin açıklamaları AF2735,AF4076 vs. gibi.Bunları altalta satırlarda,yani

0,9 AF2735
0,9 AF4076
0,9 .........
0,9 .........

gibi yapabilirmiyiz?

 

[Ömer]

D sütununda ki verileri

D deki veri & açıklama olarak mı yazmak istiyorsunuz ve bu işlemi D sütunundamı farklı sütunda mı yapmak istiyorsunuz.

.

 

[endless32]

Evet aynen dediğiniz gibi yapmak istiyorum.D'deki veriler ve açıklama içindeki değerlerini altalta satır olarak ve başka bir sütunda

 

[Ömer]

Kodları aşağıdaki gibi değiştiriniz. ( İlave kırmızı ile işaretlendi. )

Sub AciklamaMetinleri()
 
    Dim sat As Long, i As Long
 
    Range("B5:B" & Rows.Count).ClearContents
 
    sat = 5
    For i = 5 To Cells(Rows.Count, "E").End(xlUp).Row
        Cells(sat, "B") = [COLOR=red]Cells(i, "D") & " " &[/COLOR] Cells(i, "E").Comment.Text
        sat = sat + 1
    Next i
 
End Sub

.

 

[endless32]

Hocam kusura bakma anlatamadım gibi sanırım

0,9 'un verilerini altalta satır halinde tekrarlayarak yapmak istiyorum.Örnek olarak; 0,9'un açıklamasının 6 tanesinide ayrı ayrı 0,9 tekrarlanarak altalta satır halinde yazılmasını istiyorum.

1.satır 0,9 AF2735
2.satır 0,9 AF4076
3.satır 0,9 AF4166
4.satır 0,9 AF4377
5.satır 0,9 AF5176
6.satır 0,9 AF9010
7.satır 0,91 AF641
8.satır 0,91 AF1526

vs gibi istiyorum.

 

[Ömer]

Peki açıklama olmayan satır, örneğin E7 hücresini buradaki D değeri yazılcak mı yoksa es mi gecilecek.

.

 

[endless32]

yazılacak,çünkü ilerde oraya açıklama yazılabilir durumlar oluştuğunda diğer tarafa yansımasını istiyorum.

 

[Ömer]

Bu şekilde deneyiniz..

Sub AciklamaMetinleri()
 
Dim i As Long, j As Integer, Aciklama As String
Dim Adet As Long, sut As Integer, sat As Long
Dim deg
Application.ScreenUpdating = False
Range("A5:C" & Rows.Count).ClearContents
 
Adet = Rows.Count - 1: sut = 1: sat = 4
For i = 5 To Cells(Rows.Count, "E").End(xlUp).Row
    Aciklama = Application.WorksheetFunction.Trim(Replace(Cells(i, "E"). _
    Comment.Text, "&", " "))
    If Aciklama = "" Then Aciklama = Chr(160)
    deg = Split(Aciklama, " ")
    For j = 0 To UBound(deg)
        sat = sat + 1
        If sat > Adet Then
            sat = 1
            sut = sut + 1
            If sut > 3 Then
                MsgBox "Satır ve sütun sayısını ayarlayamadınız," & _
                "sütun taşacak ve hata verecek, bu yüzden duruyorum"
                Exit Sub
            End If
        End If
        Cells(sat, sut) = Cells(i, "D") & " " & deg(j)
    Next j
Next i
Application.ScreenUpdating = True
End Sub

.

 

[endless32]

Ömer hocam,
Eline sağlık fakat sorunumu çözmedi

EK'te mini bir örnek yaptım.Bu şekilde yapabilirmiyiz?

Sütunlar ayrı,
harflerin olmadığı,
Sadece rakamsal verilerin olduğu şekilde

 

[Ömer]

Eline sağlık fakat sorunumu çözmedi

#7 nolu mesajda nasıl örneklendirdiyseniz o şekilde yapmıştım.

Bu şekilde deneyiniz..

Sub AciklamaMetinleri()
 
Dim i As Long, j As Integer, Aciklama As String
Dim sut As Integer, sat As Long
Dim deg
 
Application.ScreenUpdating = False
On Error Resume Next
Range("A5:B" & Rows.Count).ClearContents
 
sut = 1: sat = 4
For i = 5 To Cells(Rows.Count, "E").End(xlUp).Row
    Aciklama = Application.WorksheetFunction.Trim(Replace(Cells(i, "E"). _
    Comment.Text, "&", " "))
    If Aciklama = "" Then Aciklama = Chr(160)
    deg = Split(Aciklama, " ")
    For j = 0 To UBound(deg)
        sat = sat + 1
        Cells(sat, sut) = Cells(i, "D")
        Cells(sat, sut + 1) = Split(deg(j), "$")(2)
    Next j
Next i
 
Application.ScreenUpdating = True
End Sub

Birde bu listelemeyi aynı sayfada değil farkı sayfada yapmanızı tavsiye ederim. Farklı sayfada yaparsanız sütun taşımlarında diğer verileri bozmazsınız.

 

[endless32]

süper bir iş oldu.Ömer hocam,uzmanım çok teşekkür ederim,eline sağlık