500 excel dosyasındaki aynı hücreyi değiştirme

[canerrrrrr]

Arkadaşlar

500 den fazla aynı formattaki excel dosyasındaki A4-A5-A6 hücrelerindeki döviz kurlarını aynı anda değiştirmek istiyorum ... bunun bir çözümü yoksa 500 üne birden teker teker girip düzeltmek zorunda kalacağım..
Yardımlarınızı bekliyorum ; şimdiden teşekkürler

 

[mustafa1205]

Değiştirmek istediğiniz hücreleri seçin. CTRL+H tuşuna basın. Eski değeri ve yeni değerleri girin ve değiştirin.

 

[turist]

Linkte ekli dosyayı inceleyiniz.
İ N D İ R

 

[gokhan83]

Paylaşımınız mükemmel olmuş. Ancak klasörde 450 dosya var bunun sadece 256 tanesini listeye alıyor bunun sebebi ne olabilir? Tüm dosya uzantıları xlsm dir.

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak aşağıdaki kodları deneyiniz.

B1,B2,B3 hücrelerinde değişecek kur bilgileri olmalıdır.

Konuyla ilgili örnek dosya ektedir.

ÖRNEK DOSYA

Dim Kur1 As Double, Kur2 As Double, Kur3 As Double

Sub Klasördeki_Dosyalara_Veri_Yaz()
    Dim Klasör As Object, S1 As Worksheet, Zaman As Double
    
    Set S1 = Sheets("Kurlar")
    
    Kur1 = S1.Range("B1")
    Kur2 = S1.Range("B2")
    Kur3 = S1.Range("B3")
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    
    If Klasör Is Nothing Then Exit Sub
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Liste (Klasör.Items.Item.Path)
    Alt_Liste (Klasör.Items.Item.Path)
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Set S1 = Nothing
    Set Klasör = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation
End Sub
 
Private Sub Liste(Yol As String)
    Dim Dosya As String, Hedef_Dosya As Workbook

    On Error Resume Next
    Dosya = Dir(Yol & "\*.xls*")
    
    While Dosya <> ""
        DoEvents
        Set Hedef_Dosya = Workbooks.Open(Yol & "\" & Dosya, False, False)
        Range("A4") = Kur1
        Range("A5") = Kur2
        Range("A6") = Kur3
        Hedef_Dosya.Close True
        Dosya = Dir
    Wend
    Set Hedef_Dosya = Nothing
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Dim Alt_Klasör As Object, Alt_Dosya As Object, Dosya As String, Hedef_Dosya As Workbook
    
    Set Alt_Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasör
    Dosya = Dir(Alt_Dosya.Path & "\*.xls*")
        While Dosya <> ""
            Application.ScreenUpdating = False
            DoEvents
            Set Hedef_Dosya = Workbooks.Open(Alt_Dosya & "\" & Dosya, False, False)
            Range("A4") = Kur1
            Range("A5") = Kur2
            Range("A6") = Kur3
            Hedef_Dosya.Close True
            Dosya = Dir
            Application.ScreenUpdating = True
        Wend
    Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
    Set Hedef_Dosya = Nothing
    Set Alt_Klasör = Nothing
End Sub

 

[gokhan83]

Korhan Bey dosya sorunsuz çalışıyor. Bu makroları ilerde kullanabilmek için arşivleyeceğim. Ancak bir sorun var. Kur rakamları yerine yazı yazdığımda "type mismatch" hatası veriyor bu hatayı nasıl aşabilirim?

 

[Korhan Ayhan]

En üst satırda göreceğiniz "Dim" ile başlayan tanımlamalarda "Double" ifadesini göreceksiniz. Onların hepsini "Variant" olarak değiştirip kullanabilirsiniz.

 

[gokhan83]

Teşekkürler Korhan Bey emeğinize sağlık.