Toplu İsim Değiştirme

[Rheago]

Merhaba arkadaşlar. Dosyam ektedir. "MAKRO" sekmesine girdiğim eski ürün isimlerinin, yanlarında belirtilen sayfa adı, hücre aralığı, büyük küçük harf ve hücre içeriği durumuna göre yeni isimlerine güncellenmesini istiyorum toplu şekilde. G sütununa da kaç adet bulup değiştirdiyse yazmasını istiyorum örnekteki gibi. Yardımlarınızı rica ederim.

 

[uzmanamele]

Merhaba

Deneyiniz.

 

[Rheago]

Merhaba

Deneyiniz.

Teşekkür ederim. Fakat koşulları E ve F sütunlarına göre ayarlamıyor sanırım. Ayrıca kaç adet bulup kaç adet değiştirdiğinin bilgisini de vermiyor.

 

[uzmanamele]

Merhaba

Bunu deneyiniz.

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Find_Replace()
    Dim S1 As Worksheet, My_Sheet As Worksheet
    Dim My_Data As Variant, Last_Row As Long
    Dim X As Long, Data_Count As Long
    Dim My_Area_1 As Range, My_Area_2 As Range, My_Area As Range
    Dim Criteria_Count As Long, Process_Time As Double
    
    Process_Time = Timer
    
    Set S1 = Sheets("MAKRO")
    
    Last_Row = WorksheetFunction.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)
    
    S1.Range("G2:G" & S1.Rows.Count).ClearContents
    
    My_Data = S1.Range("A2:G" & Last_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 My_Data(X, 1) <> "" Then
            On Error Resume Next
            Set My_Sheet = Nothing
            Set My_Sheet = Sheets(CStr(My_Data(X, 3)))
            On Error GoTo 0
            
            If Not My_Sheet Is Nothing Then
                On Error Resume Next
                Set My_Area_1 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeConstants)
                Set My_Area_2 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeBlanks)
                If Not My_Area_1 Is Nothing And Not My_Area_2 Is Nothing Then
                    Set My_Area = Application.Union(My_Area_1, My_Area_2)
                ElseIf Not My_Area_1 Is Nothing And My_Area_2 Is Nothing Then
                    Set My_Area = My_Area_1
                Else
                    Set My_Area = My_Area_2
                End If
                On Error GoTo 0
                
                If My_Data(X, 5) = "Evet" And My_Data(X, 6) = "Evet" Then
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=SUMPRODUCT(--EXACT('" & My_Data(X, 3) & _
                                         "'!" & My_Area.Address & ",""" & My_Data(X, 1) & """))")
                    End If
                End If
                
                If My_Data(X, 5) = "Evet" And My_Data(X, 6) = "Hayır" Then
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=SUMPRODUCT(--ISNUMBER(FIND(""" & My_Data(X, 1) & _
                                         """,'" & My_Data(X, 3) & "'!" & My_Area.Address & ")))")
                    End If
                End If
                
                If My_Data(X, 5) = "Hayır" And My_Data(X, 6) = "Evet" Then
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=SUMPRODUCT(--ISNUMBER(SEARCH(""" & My_Data(X, 1) & _
                                         """,'" & My_Data(X, 3) & "'!" & My_Area.Address & ")))")
                    End If
                End If
                
                If My_Data(X, 5) = "Hayır" And My_Data(X, 6) = "Hayır" Then
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=COUNTIF('" & My_Data(X, 3) & "'!" & My_Area.Address & _
                                         ",""*" & My_Data(X, 1) & "*"")")
                    End If
                End If
                
                Data_Count = Data_Count + 1
                
                My_List(Data_Count, 1) = Criteria_Count & " adet bulundu, " & Criteria_Count & " adet değişti."
                
                If Not My_Area Is Nothing Then
                    With My_Sheet.Range(My_Area.Address)
                        .Replace What:=My_Data(X, 1), _
                        Replacement:=My_Data(X, 2), _
                        LookAt:=IIf(My_Data(X, 6) = "Evet", True, False), _
                        MatchCase:=IIf(My_Data(X, 5) = "Evet", True, False)
                    End With
                End If
            End If
        End If
    Next
    
    If Data_Count > 0 Then
        S1.Range("G2").Resize(Data_Count) = My_List
        MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set My_Sheet = Nothing
End Sub

 

[Korhan Ayhan]

Önerdiğim kodu biraz daha hızlandırdım.

 

[Rheago]

Alternatif;

Option Explicit

Sub Find_Replace()
    Dim S1 As Worksheet, My_Sheet As Worksheet
    Dim My_Data As Variant, Last_Row As Long
    Dim X As Long, Data_Count As Long
    Dim My_Area_1 As Range, My_Area_2 As Range, My_Area As Range
    Dim Criteria_Count As Long, Process_Time As Double
   
    Process_Time = Timer
   
    Set S1 = Sheets("MAKRO")
   
    Last_Row = WorksheetFunction.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)
   
    S1.Range("G2:G" & S1.Rows.Count).ClearContents
   
    My_Data = S1.Range("A2:G" & Last_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 My_Data(X, 1) <> "" Then
            On Error Resume Next
            Set My_Sheet = Nothing
            Set My_Sheet = Sheets(CStr(My_Data(X, 3)))
            On Error GoTo 0
           
            If Not My_Sheet Is Nothing Then
                If My_Data(X, 5) = "Evet" And My_Data(X, 6) = "Evet" Then
                    On Error Resume Next
                    Set My_Area_1 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeConstants)
                    Set My_Area_2 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeBlanks)
                    Set My_Area = Application.Union(My_Area_1, My_Area_2)
                    On Error GoTo 0
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=SUMPRODUCT(--EXACT('" & My_Data(X, 3) & _
                                         "'!" & My_Area.Address & ",""" & My_Data(X, 1) & """))")
                    End If
                End If
               
                If My_Data(X, 5) = "Evet" And My_Data(X, 6) = "Hayır" Then
                    On Error Resume Next
                    Set My_Area_1 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeConstants)
                    Set My_Area_2 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeBlanks)
                    Set My_Area = Application.Union(My_Area_1, My_Area_2)
                    On Error GoTo 0
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=SUMPRODUCT(--ISNUMBER(FIND(""" & My_Data(X, 1) & _
                                         """,'" & My_Data(X, 3) & "'!" & My_Area.Address & ")))")
                    End If
                End If
               
                If My_Data(X, 5) = "Hayır" And My_Data(X, 6) = "Evet" Then
                    On Error Resume Next
                    Set My_Area_1 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeConstants)
                    Set My_Area_2 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeBlanks)
                    Set My_Area = Application.Union(My_Area_1, My_Area_2)
                    On Error GoTo 0
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=SUMPRODUCT(--ISNUMBER(SEARCH(""" & My_Data(X, 1) & _
                                         """,'" & My_Data(X, 3) & "'!" & My_Area.Address & ")))")
                    End If
                End If
               
                If My_Data(X, 5) = "Hayır" And My_Data(X, 6) = "Hayır" Then
                    On Error Resume Next
                    Set My_Area_1 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeConstants)
                    Set My_Area_2 = My_Sheet.Range(My_Data(X, 4)).SpecialCells(xlCellTypeBlanks)
                    Set My_Area = Application.Union(My_Area_1, My_Area_2)
                    On Error GoTo 0
                    If Not My_Area Is Nothing Then
                        Criteria_Count = Evaluate("=COUNTIF('" & My_Data(X, 3) & "'!" & My_Area.Address & _
                                         ",""*" & My_Data(X, 1) & "*"")")
                    End If
                End If
               
                Data_Count = Data_Count + 1
               
                My_List(Data_Count, 1) = Criteria_Count & " adet bulundu, " & Criteria_Count & " adet değişti."
               
                If Not My_Area Is Nothing Then
                    With My_Sheet.Range(My_Area.Address)
                        .Replace What:=My_Data(X, 1), _
                        Replacement:=My_Data(X, 2), _
                        LookAt:=IIf(My_Data(X, 6) = "Evet", True, False), _
                        MatchCase:=IIf(My_Data(X, 5) = "Evet", True, False)
                    End With
                End If
            End If
        End If
    Next
   
    If Data_Count > 0 Then
        S1.Range("G2").Resize(Data_Count) = My_List
        MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set My_Sheet = Nothing
End Sub

Bu kod tam olarak istediğim şeyi yapıyor. Destek olan herkesin ellerine sağlık.

 

[Rheago]

Önerdiğim kodu biraz daha hızlandırdım.

Kodu asıl dosyama taşıdığımda hiçbir veriyi bulup değiştirmediğini fark ettim. Bunun sebebi fazla verimin olması. Değiştirilecek sayfada 20.000 den fazla satır mevcut. Fazla satır olunca bulup değiştirmiyor. Satır sayısını 1.000 e falan düşürünce bulup değiştiriyor.

 

[Korhan Ayhan]

Bahsettiğiniz veriler formüllü hücreler mi içeriyor?

 

[Rheago]

Bahsettiğiniz veriler formüllü hücreler mi içeriyor?

Hayır. Dış veri bağlantısı içeriyor. Ama dış veri bağlantısını kesip, tabloyu normal aralığa dönüştürünce de değiştirmiyor. Fakat dış veri bağlantımda satır sayısını 20.000 den 1.000 adete kadar düşürdüğümde çalışıyor.

 

[Korhan Ayhan]

Kod hızlı çalışsın diye F5-Özel menüsünü kullanarak tanımlanan sütunda dolu sabit hücrelerde işlem yapmasını sağlamıştım.

Onu iptal edersek sanırım sorun çözülür. Ama bu sefer yavaşlama durumu olur.

 

[Rheago]

Kod hızlı çalışsın diye F5-Özel menüsünü kullanarak tanımlanan sütunda dolu sabit hücrelerde işlem yapmasını sağlamıştım.

Onu iptal edersek sanırım sorun çözülür. Ama bu sefer yavaşlama durumu olur.

Neden hata verdiğini kesin olarak tespit ettim sanırsam. Dış veri bağlantım "A2:F23605" aralığına kadar veriyi çekiyor. 23605. satırdaki verileri silince makro sorunsuz çalışıyor. Bahsettiğiniz özelliği nasıl iptal edebiliriz?

 

[Korhan Ayhan]

Önerdiğim kodda bir düzeltme yapacağım. Bu düzeltmeden sonra sorun hala devam ederse farklı bir kod paylaşırım.

Düzeltmeyi yaptığımda buraya yazarım.

 

[Korhan Ayhan]

#5 nolu mesjımdaki kodu revize ettim. Tekrar deneyiniz.

 

[Rheago]

#5 nolu mesjımdaki kodu revize ettim. Tekrar deneyiniz.

Son yaptığınız sorunsuz çalışıyor hocam. Elinize sağlık.