Hücreye çift tıklama makrosu

Korhan Ayhan · 22 Şubat 2023

Anlaşamadığımız nokta şurası;

Siz sarı renkle taşınacak hücreleri belirtmişsiniz. Doğal olarakta ben ifadelerimde sarı renkli hücre açıklamasını kullanıyorum.

Ben ifadelerinizden taşınacak hücreler için master bir anahtar yakalamaya çalışıyorum. Bunu yakalayamazsak sabaha kadar karşılıklı yazıp dururuz.

asdsxx · 22 Şubat 2023

Korhan Ayhan' Alıntı:
Anlaşamadığımız nokta şurası;

Siz sarı renkle taşınacak hücreleri belirtmişsiniz. Doğal olarakta ben ifadelerimde sarı renkli hücre açıklamasını kullanıyorum.

Ben ifadelerinizden taşınacak hücreler için master bir anahtar yakalamaya çalışıyorum. Bunu yakalayamazsak sabaha kadar karşılıklı yazıp dururuz.

Kod yazmayı bilmiyorum ama yazılan bazı kodları yorumlayabiliyorum. Siz bir önceki kodda 21. mesaj
If IsNumeric(Left(My_Data(X, 1), 1)) Then

diye bir ifade var. sanırım hücredeki verinin sol tarafı "sayısal numara ise" diyorsunuz. Buradan yola çıkarak bunun devamına
"sayısal numara ise ve önceki hücrenin numara değerinden küçük ise" B sütununa taşı
diye bir ek yapılabilir mi

Korhan Ayhan · 22 Şubat 2023

Bahsettiğiniz anahtarda soldan kaç karaktere bakmak gerekir.

asdsxx · 24 Şubat 2023

Korhan Ayhan' Alıntı:
Bahsettiğiniz anahtarda soldan kaç karaktere bakmak gerekir.

Korhan Bey yukarıdaki kriteri nasıl yakalayacağımızı buldum sanki
İki aşamalı bir işlemden sonra sanki olur gibi geliyor
1. Aşama: 21. mesajdaki koda "Yazı rengi kırmızı" olan hücreleri işlem sonrası yine kırmızı veya bir kriter yakalamaya yarayacak şekilde aktarmak
2. aşama: bu kriterleri taşıyan hücreleri bir soldaki sütunda aynı satır nolu hücreye taşımak.

Çünkü ilk ham verilerde taşınmasını istediğim verilerin tamamı kırmızı yazı rengi. Belki buradan kod oluşturabiliriz.

ilk ham veri görüntüsü: 21. mesajdaki kod bu verileri düzenliyor. Koda ekleme yapılarak yazı puntosu kırmızı olanlar yine kırmızı olacak şekilde düzenlenir sonra,
Veri ilk hali

Alt soldaki görüntü makronun düzelttiği hali (yazı sitili kırmızı değil)
Eğer makroya böyle bir ilave yapılarak ilk halindeki kırmızı hücreleri yine kırmızı veya kriter oluşturacak bir şekilde düzenleyebilrsek, son aşamada da bu kriterleri taşıyan hücreleri sola taşıyabiliriz.

Korhan Ayhan · 24 Şubat 2023

Mesajınızı okuyunca biraz kafam karıştı.

Verilerinizin ham halinde taşınacak verilerin YAZI RENGİ kırmızı mı?

asdsxx · 24 Şubat 2023

Korhan Ayhan' Alıntı:
Mesajınızı okuyunca biraz kafam karıştı.

Verilerinizin ham halinde taşınacak verilerin YAZI RENGİ kırmızı mı?

sizin 21. mesajdaki kodun yapacağı işlemde taşınmasını istediğim hücrelerin yazı rengi kırmızı.
Ben hep kod işlem yaptıktan sonraki aşamadan sonra kriter aramaya çalıştık.
Halbuki ben ilk kopyalayıp yapıştırdığım verilerde ilgili kısımlar kırmızı. Buradan yola çıkabiliriz.
Kod aynı işlemi yapacak sadece hücreleri düzeltirken yazı rengi kırmızı olanları yine kırmızı yapacak. Sonra biz yazı rengi kırmızı olanları soldaki hücreye taşıyacağız.

asdsxx · 24 Şubat 2023

Yalnız burada dikkat etmemiz gereken durum hücrenin içindeki yazının tamamı kırmızı olanlar alınacak. Hücrede cümlelerin işinde çeşitli renkli yazılar var bunlardan bir veya iki kelimesi kırmızı diğerleri farklı renkli olanlar değil. Hücredeki verinin yazı rengi tümü kırmızı hatta koyu kırmızı
Ben bunu kopyalayıp excel hücresine yapıştırınca da aynı renklerle geliyor.

Korhan Ayhan · 24 Şubat 2023

Deneyiniz.

Kodu 1 kez çalıştırmalısınız...

C++:

Option Explicit

Sub Red_Cells_Move()
    Dim Rng As Range
        
    Application.ScreenUpdating = False
    
    Range("B2:B" & Rows.Count).Clear
    
    For Each Rng In Range("C2:C" & Cells(Rows.Count, 3).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then Rng.Cut Rng.Offset(, -1)
    Next

    Application.ScreenUpdating = True
    
    MsgBox "Kırmızı yazı fontlu hücreler B sütununa taşınmıştır.", vbInformation
End Sub

asdsxx · 24 Şubat 2023

Korhan Ayhan' Alıntı:

Deneyiniz.

Kodu 1 kez çalıştırmalısınız...

C++:

Option Explicit

Sub Red_Cells_Move()
    Dim Rng As Range
       
    Application.ScreenUpdating = False
   
    Range("B2:B" & Rows.Count).Clear
   
    For Each Rng In Range("C2:C" & Cells(Rows.Count, 3).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then Rng.Cut Rng.Offset(, -1)
    Next

    Application.ScreenUpdating = True
   
    MsgBox "Kırmızı yazı fontlu hücreler B sütununa taşınmıştır.", vbInformation
End Sub

Korhan Bey Teşekkürler. Kod çalışıyor.
Ancak 21. mesajdaki kod işlem yaparken ilk ham veriyi (Farklı hücrelerdeki verileri başındaki rakamları baz alarak tek hücrede birleştiriyordu) o esnada düzelttiği hücredeki yazı kırmızı is; kırmızı renkli yazıları yine kod işlem yaptıktan sonra yine kırmızı yazı renkli olarak aktaracak. Diğer hücrelerdeki veriler varsayılan yazı renginde (21. mesajdaki kod tüm veriyi varsayılan olarak atıyor) kalacak.
Bu makro ancak ilk makro (21. Mesaj) işlemi anlatılan şeklinde gerçekleştirdikten sonra 2. aşama olarak görev yapacak
Aşağıdaki örnek dosyada uygulamalı olarak anlatmaya çalıştım

Korhan Ayhan · 24 Şubat 2023

Aşağıdaki tek kod ile sonuca gidebilirsiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim My_Data As Variant, X As Long, Y As Long
    Dim Count_Data As Long, Find_Data As Range, Rng As Range
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Range("B:C").Clear
   
    My_Data = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value
   
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
   
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If IsNumeric(Left(My_Data(X, 1), 1)) Then
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Data(X, 1)
            For Y = X + 1 To UBound(My_Data, 1) - 1
                If Not IsNumeric(Left(My_Data(Y, 1), 1)) Then
                    My_List(Count_Data, 1) = My_List(Count_Data, 1) & vbLf & My_Data(Y, 1)
                Else
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next
   
    Range("B:C").WrapText = True
    Range("C1") = "DÜZENLENMİŞ VERİLER"
    Range("C1").Font.Size = 20
    Range("C1").Font.Bold = True
    Range("C1").HorizontalAlignment = xlCenter
    Range("C2").Resize(Count_Data) = My_List
   
    Range("C:C").Replace Chr(10), "|"
    Range("C:C").Replace vbCr, "|"
    Range("C:C").Replace vbLf, "|"
  
    For Each Rng In Range("C:C").SpecialCells(xlCellTypeConstants)
        For X = 10 To 1 Step -1
            Rng = Replace(Rng, String(X, "|"), Chr(10))
        Next
    Next
  
    For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then
            Set Find_Data = Range("C:C").Find(Rng.Value, , , xlWhole)
            If Not Find_Data Is Nothing Then
                Find_Data.Font.ColorIndex = 3
                Find_Data.Font.Bold = Rng.Font.Bold
            End If
        End If
    Next
  
    For Each Rng In Range("C2:C" & Cells(Rows.Count, 3).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then
            Rng.Offset(, -1) = Rng
            Rng.Offset(, -1).Font.Bold = Rng.Font.Bold
            Rng.Offset(, -1).Font.Color = Rng.Font.Color
            Rng = ""
        End If
    Next
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

asdsxx · 24 Şubat 2023

Korhan Bey; ilginize, ve sabrınıza Çok teşekkür ederim.
Ellerinize sağlık. Tam istediğim gibi oldu.
Allah razı olsun.

Korhan Ayhan · 25 Şubat 2023

Özelden sorduğunuzda konu bütünlüğü bozuluyor. Lütfen sorularınızı forum üzerinden sorup takip ediniz.

Kodu tekrar revize ettim. Deneyiniz.

asdsxx · 25 Şubat 2023

Teşekkürler, Korhan Bey

asdsxx · 3 Mart 2023

Korhan Ayhan' Alıntı:

Özelden mesaj yazmanıza gerek yok. Foruma yazarsanız benim dışımda cevap vermek isteyen arkadaşlarda başlığınıza yorum yapabilirler.

Paylaştığınız dosyanıza göre aşağıdaki kodu deneyiniz.

Sonuçlar B sütununa yazılmaktadır. İşlemler tamamen A sütununda olsun derseniz kod içinde geçen B sütun harflerini A olarak revize edebilirsiniz.

C++:

Option Explicit

Sub Concatenate_Cell()
    Dim My_Data As Variant, X As Long, Y As Long
    Dim Count_Data As Long, Rng As Range
  
    Application.ScreenUpdating = False
 
    Range("B:B").ClearContents
  
    My_Data = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value
  
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
  
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If IsNumeric(Left(My_Data(X, 1), 1)) Then
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Data(X, 1)
            For Y = X + 1 To UBound(My_Data, 1) - 1
                If Not IsNumeric(Left(My_Data(Y, 1), 1)) Then
                    My_List(Count_Data, 1) = My_List(Count_Data, 1) & vbLf & My_Data(Y, 1)
                Else
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next
  
    Range("B2").Resize(Count_Data) = My_List
  
    Range("B:B").Replace Chr(10), "|"
    Range("B:B").Replace vbCr, "|"
    Range("B:B").Replace vbLf, "|"
 
    For Each Rng In Range("B:B").SpecialCells(xlCellTypeConstants)
        For X = 10 To 1 Step -1
            Rng = Replace(Rng, String(X, "|"), Chr(10))
        Next
    Next
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Bey yukarıdaki kodu Arapça numara ile başlayan Arapça metinler için revize edebilirmiyiz.

Korhan Ayhan · 4 Mart 2023

Örnek dosya paylaşırsanız deneme yapabilirim.

asdsxx · 4 Mart 2023

Korhan Ayhan' Alıntı:
Örnek dosya paylaşırsanız deneme yapabilirim.

50. Mesajdaki kod'a uyarlanırsa daha iyi olur.

Korhan Ayhan · 4 Mart 2023

Deneyiniz.

C++:

Option Explicit

Sub Concatenate_Cell()
    Dim My_Data As Variant, X As Long, Y As Long
    Dim Count_Data As Long, Rng As Range
    Dim WF As WorksheetFunction, No As Variant
 
    Application.ScreenUpdating = False

    Set WF = WorksheetFunction

    Range("B:B").ClearContents
 
    My_Data = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value
 
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
 
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        On Error Resume Next
        No = ""
        No = WF.Dec2Hex(Left(My_Data(X, 1), 1))
        On Error GoTo 0
        If IsNumeric(No) Then
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Data(X, 1)
            For Y = X + 1 To UBound(My_Data, 1) - 1
                On Error Resume Next
                No = ""
                No = WF.Dec2Hex(Left(My_Data(Y, 1), 1))
                On Error GoTo 0
                If Not IsNumeric(No) Then
                    My_List(Count_Data, 1) = My_List(Count_Data, 1) & vbLf & My_Data(Y, 1)
                Else
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next
 
    Range("B2").Resize(Count_Data) = My_List
    Range("B2").Resize(Count_Data).Font.Name = "Traditional Arabic"

    Range("B:B").Replace Chr(10), "|"
    Range("B:B").Replace vbCr, "|"
    Range("B:B").Replace vbLf, "|"

    For Each Rng In Range("B:B").SpecialCells(xlCellTypeConstants)
        For X = 10 To 1 Step -1
            Rng = Replace(Rng, String(X, "|"), Chr(10))
        Next
    Next

    Set WF = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

asdsxx · 4 Mart 2023

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Concatenate_Cell()
    Dim My_Data As Variant, X As Long, Y As Long
    Dim Count_Data As Long, Rng As Range
    Dim WF As WorksheetFunction, No As Variant

    Application.ScreenUpdating = False

    Set WF = WorksheetFunction

    Range("B:B").ClearContents

    My_Data = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value

    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)

    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        On Error Resume Next
        No = ""
        No = WF.Dec2Hex(Left(My_Data(X, 1), 1))
        On Error GoTo 0
        If IsNumeric(No) Then
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Data(X, 1)
            For Y = X + 1 To UBound(My_Data, 1) - 1
                On Error Resume Next
                No = ""
                No = WF.Dec2Hex(Left(My_Data(Y, 1), 1))
                On Error GoTo 0
                If Not IsNumeric(No) Then
                    My_List(Count_Data, 1) = My_List(Count_Data, 1) & vbLf & My_Data(Y, 1)
                Else
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next

    Range("B2").Resize(Count_Data) = My_List
    Range("B2").Resize(Count_Data).Font.Name = "Traditional Arabic"

    Range("B:B").Replace Chr(10), "|"
    Range("B:B").Replace vbCr, "|"
    Range("B:B").Replace vbLf, "|"

    For Each Rng In Range("B:B").SpecialCells(xlCellTypeConstants)
        For X = 10 To 1 Step -1
            Rng = Replace(Rng, String(X, "|"), Chr(10))
        Next
    Next

    Set WF = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Koray Bey teşekkürler. Kod çalışıyor.
Yukarıda 50. Mesajdaki kod revize edilebilirse daha iyi olur.
Yani "C" sütununa düzeltilmiş halini taşıdıktan sonra "B" sütununa Kırmızı yazı fontu olanları taşıyacak.
Örnek dosyada açıklama var

Korhan Ayhan · 4 Mart 2023

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim My_Data As Variant, X As Long, Y As Long
    Dim Count_Data As Long, Find_Data As Range, Rng As Range
    Dim WF As WorksheetFunction, No As Variant
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Set WF = WorksheetFunction
    
    Range("B:C").Clear
   
    My_Data = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value
   
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
   
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        On Error Resume Next
        No = ""
        No = WF.Dec2Hex(Left(My_Data(X, 1), 1))
        On Error GoTo 0
        If IsNumeric(No) Then
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Data(X, 1)
            For Y = X + 1 To UBound(My_Data, 1) - 1
                On Error Resume Next
                No = ""
                No = WF.Dec2Hex(Left(My_Data(Y, 1), 1))
                On Error GoTo 0
                If Not IsNumeric(No) Then
                    My_List(Count_Data, 1) = My_List(Count_Data, 1) & vbLf & My_Data(Y, 1)
                Else
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next
   
    Range("B:C").WrapText = True
    Range("C1") = "DÜZENLENMİŞ VERİLER"
    Range("C1").Font.Size = 20
    Range("C1").Font.Bold = True
    Range("C1").HorizontalAlignment = xlCenter
    Range("C2").Resize(Count_Data) = My_List
    Range("C2").Resize(Count_Data).Font.Name = "Traditional Arabic"
   
    Range("C:C").Replace Chr(10), "|"
    Range("C:C").Replace vbCr, "|"
    Range("C:C").Replace vbLf, "|"
  
    For Each Rng In Range("C:C").SpecialCells(xlCellTypeConstants)
        For X = 10 To 1 Step -1
            Rng = Replace(Rng, String(X, "|"), Chr(10))
        Next
    Next
  
    For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then
            Set Find_Data = Range("C:C").Find(Rng.Value, , , xlWhole)
            If Not Find_Data Is Nothing Then
                Find_Data.Font.ColorIndex = 3
                Find_Data.Font.Bold = Rng.Font.Bold
            End If
        End If
    Next
  
    For Each Rng In Range("C2:C" & Cells(Rows.Count, 3).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then
            Rng.Offset(, -1) = Rng
            Rng.Offset(, -1).Font.Bold = Rng.Font.Bold
            Rng.Offset(, -1).Font.Color = Rng.Font.Color
            Rng = ""
        End If
    Next
  
    Set WF = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

asdsxx · 4 Mart 2023

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Dim My_Data As Variant, X As Long, Y As Long
    Dim Count_Data As Long, Find_Data As Range, Rng As Range
    Dim WF As WorksheetFunction, No As Variant
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Set WF = WorksheetFunction
   
    Range("B:C").Clear
  
    My_Data = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value
  
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
  
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        On Error Resume Next
        No = ""
        No = WF.Dec2Hex(Left(My_Data(X, 1), 1))
        On Error GoTo 0
        If IsNumeric(No) Then
            Count_Data = Count_Data + 1
            My_List(Count_Data, 1) = My_Data(X, 1)
            For Y = X + 1 To UBound(My_Data, 1) - 1
                On Error Resume Next
                No = ""
                No = WF.Dec2Hex(Left(My_Data(Y, 1), 1))
                On Error GoTo 0
                If Not IsNumeric(No) Then
                    My_List(Count_Data, 1) = My_List(Count_Data, 1) & vbLf & My_Data(Y, 1)
                Else
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next
  
    Range("B:C").WrapText = True
    Range("C1") = "DÜZENLENMİŞ VERİLER"
    Range("C1").Font.Size = 20
    Range("C1").Font.Bold = True
    Range("C1").HorizontalAlignment = xlCenter
    Range("C2").Resize(Count_Data) = My_List
    Range("C2").Resize(Count_Data).Font.Name = "Traditional Arabic"
  
    Range("C:C").Replace Chr(10), "|"
    Range("C:C").Replace vbCr, "|"
    Range("C:C").Replace vbLf, "|"
 
    For Each Rng In Range("C:C").SpecialCells(xlCellTypeConstants)
        For X = 10 To 1 Step -1
            Rng = Replace(Rng, String(X, "|"), Chr(10))
        Next
    Next
 
    For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then
            Set Find_Data = Range("C:C").Find(Rng.Value, , , xlWhole)
            If Not Find_Data Is Nothing Then
                Find_Data.Font.ColorIndex = 3
                Find_Data.Font.Bold = Rng.Font.Bold
            End If
        End If
    Next
 
    For Each Rng In Range("C2:C" & Cells(Rows.Count, 3).End(3).Row)
        If Rng.Font.ColorIndex = 3 Then
            Rng.Offset(, -1) = Rng
            Rng.Offset(, -1).Font.Bold = Rng.Font.Bold
            Rng.Offset(, -1).Font.Color = Rng.Font.Color
            Rng = ""
        End If
    Next
 
    Set WF = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkürler...

Hücreye çift tıklama makrosu

Korhan Ayhan

Administrator

asdsxx

Korhan Ayhan

Administrator

asdsxx

Ekli dosyalar

Korhan Ayhan

Administrator

asdsxx

asdsxx

Korhan Ayhan

Administrator

asdsxx

Ekli dosyalar

Korhan Ayhan

Administrator

asdsxx

Korhan Ayhan

Administrator

asdsxx

asdsxx

Korhan Ayhan

Administrator

asdsxx

Ekli dosyalar

Korhan Ayhan

Administrator

asdsxx

Korhan Ayhan

Administrator

asdsxx