• DİKKAT

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

Yazdığım bir makroyu diğer sayfalara nasıl tek seferde uygularım?

B

buggsbunny

Katılım
17 Mayıs 2012
Mesajlar
102
Excel Vers. ve Dili
Office 2019, Türkçe
Elimde bir excel dosyam var 85 sekmeli. ve ben aşağıdaki kodu 81 ilin adından oluşan sekmelere uygulamak istiyorum. seçtiğim sekmelere uygula şeklinde de olabilir, 81 il adından oluşan sekmeleri koda katarakta olabilir. Bunu nasıl yaparım

Kod: 
Sub kelime_bicimlendir()
    Dim xHStr As String, xStrTmp As String
    Dim xHStrLen As Long, xCount As Long, I As Long
    Dim xCell As Range
    Dim xArr
    On Error Resume Next
    
     Range("N33:AB40").Select
    Selection.ClearContents
    ActiveCell.FormulaR1C1 = "=R[12]C[6]"
    Range("N33:AB40").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   Range("C55:J57").Select
    Selection.Copy
    Range("C51").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
     Cells(33, "N").Select
    xHStr = Cells(51, "C")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
       
       xHStr = Cells(51, "d")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(51, "e")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(51, "F")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True

xHStr = Cells(51, "G")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(51, "H")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(51, "I")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
     xHStr = Cells(51, "J")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
        xHStr = Cells(52, "C")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(52, "D")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(52, "E")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(52, "F")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(52, "G")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(53, "c")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(53, "d")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(53, "e")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(53, "f")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
    
    xHStr = Cells(53, "g")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Font.Bold = True
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Name = "Arial Black"
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Size = 13
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
End Sub
 
Merhaba,

Aşağıdaki kodlar sizin kodlarınızı çağırır. Ya seçili sayfaya ya da tüm sayfalara uygulanır.

Kod: 
Sub Seçili_Sheets()
 
    Dim sh  As Object, _
        i   As Integer
    
    i = Application.InputBox("1. Seçili Sayfalar, 2. Tüm Sayfalar ", "Seçimi Belirleyiniz", 1, Type:=1)
    If i = 0 Then Exit Sub
    
    If i = 1 Then
        MsgBox "Seçilen Sayfa Sayısı : " & ActiveWindow.SelectedSheets.Count
        For Each sh In ActiveWindow.SelectedSheets
            [COLOR="red"]kelime_bicimlendir[/COLOR]
        Next sh
    Else
        For Each sh In Worksheets
            [B][COLOR="Red"]kelime_bicimlendir[/COLOR][/B]
        Next sh
    End If

End If
 
Ohoo daha önce de sayfaları pdf yapmak için sormuşsunuz. Benzer bir konu. Oradaki kodları inceleseydiniz bu soruyu kendiniz de çözebilirdiniz.
 
Necdet' Alıntı:
Ohoo daha önce de sayfaları pdf yapmak için sormuşsunuz. Benzer bir konu. Oradaki kodları inceleseydiniz bu soruyu kendiniz de çözebilirdiniz.
Genişletmek için tıkla ...

kodlarda o kadar da iyi değilim yardım almak için buraya yazıyorum. Bildiğim birşey için sizi uğraştırmam. Mesela bu kodu benim yazdığım kodun içine mi yazcam başka bi buton olarak mı ekleyeceğim bilmiyorum
 
Sizin kodlar değil benim gönderdiğim kodları butona bağlayın, o zaten sizin kodları çağıracaktır.
 
Necdet' Alıntı:
Sizin kodlar değil benim gönderdiğim kodları butona bağlayın, o zaten sizin kodları çağıracaktır.
Genişletmek için tıkla ...

Dediğinizi yaptım kod çalıştı ancak şöyle bir sıkıntı var. tüm sekmeler seçili olduğu için birinde yaptığı değişikliği diğer hücrelere aynı anda uygulamaya çalışıyor, ilk tıkladığım sayfa hariç diğerlerine sadece metin yapıştırıyor biçimlendirme yapmıyor
 
81 il adından oluşan sekmeleri içeren koda nasıl uygularım
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst