Excel Dosyası Açıksa Makro Çalışmıyor

C

cengizyener

Altın Üye
Katılım
10 Kasım 2022
Mesajlar
27
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
10-11-2028
Merhaba Arkadaşlar,

Aşağıda excelde kullandığım bir kod yer alamaktadır. Kodun çalışma mantığı mevcut excel dosyamdaki kaynak sayfasını temizliyor daha sonra konumunu seçtiğim klasördeki tüm excel dosyalarını açıp içindeki verileri makromun olduğu excel dosyasına yapıştırıyor fakat o klasördeki bir excel dosyası açıksa makro hata veriyor. Ben şunu istiyorum eğer excel dosyası açıksa salt okunur olarak açıp verileri almaya devam etmesini istiyorum bu kodda ne gibi bir güncelleme yapmalıyım yardımcı olur musunuz?



Kod: 
Sub Dosyalarin_bulundugu_klasoru_sec()
Dim kaynak As String
[BM1].Clear
'aşağıdaki yeşil renkli kodlar klasörün seçim yapılarak alınması için kullanılacak kodlardır.
'Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Dosyalarin bulundugu Klasoru Secin", 50, &H0)
'If Not Klasor Is Nothing Then
kaynak = "\\192.168.1.201\uretim\ÜRETİM RAPORLARI"

'kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
[BM1] = kaynak

'End If
End Sub





Sub Birlestir()


Sheets("Tümİmalat").Select
Range("A5:AC65536").ClearContents ' veri yenilendiğinde hangi alanların delete tuşu gibi silineeceğini gösteriyor

Dosyalarin_bulundugu_klasoru_sec

Application.ScreenUpdating = False 'Eğer ekrana yazmaya başlamadan önce false yaparsanız ekrana yazmaz ama hafızaya yazar.en sonunda true yaptığınızda ise hafızada yazılı olanları excele yazar

If [BM1] = "" Then End

Dim t, dosyasay As Integer
Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object
Dim sonsatir As Long, sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder([BM1]).Files

dosyasay = 0

ThisWorkbook.Activate
ThisWorkbook.Sheets("Tümİmalat").Select

For Each fls In f
            ' dosya türü xlsm olanlardan ve dosya adı 2023 ile başlamayanlardan veri alacak
    If fso.GetExtensionName(fls) = "xlsm" And Left(fls.Name, 2) <> "~$" Then 'dosya türü xlsm olanlardan veri alacak
       
        If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False
      
        'For Each sh In Workbooks(fls.Name).Worksheets
            sonsat1 = Sheets("Üretim Listesi").Cells(65536, "F").End(xlUp).Row
            If sonsat1 > 4 Then ' Son dolu satır 4 ten büyükse verileri aktarıyor
                liste = Sheets("Üretim Listesi").Range("A5:AC" & sonsat1).Value
                sonsat2 = ThisWorkbook.Sheets("Tümİmalat").Cells(65536, "B").End(xlUp).Row + 1
                ThisWorkbook.Sheets("Tümİmalat").Range("A" & sonsat2).Resize(UBound(liste), 29) = liste
                Erase liste
            End If
        'Next sh
        dosyasay = dosyasay + 1
        Workbooks(fls.Name).Close False
    End If
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("Tümİmalat").Select



Application.ScreenUpdating = True
Sheets("Kaynak").Select
Range("A1").Select
MsgBox dosyasay & " adet dosyadaki bilgiler Programa aktarildi."


End Sub
 
Trilenium

Trilenium

Destek Ekibi
Destek Ekibi
Katılım
16 Eylül 2008
Mesajlar
1,180
Excel Vers. ve Dili
Microsoft Office 2019 English
Sub AktarVeriler()
Dim wsVeri As Worksheet
Dim wsRapor As Worksheet
Dim lastRow As Long
Dim raporRow As Long
Dim i As Long
Dim hesapAdi As String
Dim fso As Object
Dim f As Object
Dim fls As Object
Dim dosyasay As Long

' FileSystemObject için referans ayarı
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("klasor_yolu").Files ' Klasor_yolu'nu kendi klasör yolunuzla değiştirin

Application.ScreenUpdating = False

' Verilerin aktarılması
For Each fls In f
' dosya türü xlsm olanlardan ve dosya adı 2023 ile başlamayanlardan veri alacak
If fso.GetExtensionName(fls) = "xlsm" And Left(fls.Name, 2) <> "~$" Then
On Error Resume Next ' Hataları yakalamak için
Set wsVeri = Workbooks.Open(fls, ReadOnly:=True).Sheets("Üretim Listesi")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
GoTo NextFile
End If
On Error GoTo 0

' Verileri aktarma işlemi
sonsat1 = wsVeri.Cells(65536, "F").End(xlUp).Row
If sonsat1 > 4 Then
liste = wsVeri.Range("A5:AC" & sonsat1).Value
sonsat2 = ThisWorkbook.Sheets("Tümİmalat").Cells(65536, "B").End(xlUp).Row + 1
ThisWorkbook.Sheets("Tümİmalat").Range("A" & sonsat2).Resize(UBound(liste), 29).Value = liste
Erase liste
End If

Workbooks(fls.Name).Close False
dosyasay = dosyasay + 1
NextFile:
End If
Next fls

ThisWorkbook.Activate
ThisWorkbook.Sheets("Tümİmalat").Select
Application.ScreenUpdating = True
Sheets("Kaynak").Select
Range("A1").Select
MsgBox dosyasay & " adet dosyadaki bilgiler programa aktarildi."
End Sub



şu kod ile deneyebilir misiniz
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
191
Excel Vers. ve Dili
Excel 2021 Türkçe
Merhaba, deneyip sonucu paylaşabilir misiniz;

Kod: 
Sub Dosyalarin_bulundugu_klasoru_sec() 
    Dim kaynak As String
    'aşağıdaki yeşil renkli kodlar klasörün seçim yapılarak alınması için kullanılacak kodlardır.      
    'Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Dosyalarin bulundugu Klasoru Secin", 50, &H0)
    'If Not Klasor Is Nothing Then  
    [BM1].Clear
    kaynak = "\\192.168.1.201\uretim\ÜRETİM RAPORLARI"
    [BM1] = kaynak
   'End If
End Sub

Sub Birlestir()
    Sheets("Tümİmalat").Select
    Range("A5:AC65536").ClearContents
    Dosyalarin_bulundugu_klasoru_sec
    Application.ScreenUpdating = False
    If [BM1] = "" Then End
    Dim t As Integer, dosyasay As Integer
    Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object
    Dim sonsatir As Long, sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
    Dim wb As Workbook
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.getfolder([BM1]).Files
    dosyasay = 0
    ThisWorkbook.Activate
    ThisWorkbook.Sheets("Tümİmalat").Select
    For Each fls In f
        If fso.GetExtensionName(fls) = "xlsm" And Left(fls.Name, 2) <> "~$" Then
            On Error Resume Next
            Set wb = Workbooks.Open(fls.Path, ReadOnly:=True)
            If wb Is Nothing Then
                On Error GoTo 0
                GoTo SonrakiDosya
            End If
            On Error GoTo 0
            With wb
                sonsat1 = .Sheets("Üretim Listesi").Cells(.Sheets("Üretim Listesi").Rows.Count, "F").End(xlUp).Row
                If sonsat1 > 4 Then
                    liste = .Sheets("Üretim Listesi").Range("A5:AC" & sonsat1).Value
                    sonsat2 = ThisWorkbook.Sheets("Tümİmalat").Cells(ThisWorkbook.Sheets("Tümİmalat").Rows.Count, "B").End(xlUp).Row + 1
                    ThisWorkbook.Sheets("Tümİmalat").Range("A" & sonsat2).Resize(UBound(liste, 1), UBound(liste, 2)).Value = liste
                    Erase liste
                End If
            End With
            dosyasay = dosyasay + 1
            wb.Close False
        End If
SonrakiDosya:
    Next fls
    ThisWorkbook.Activate
    ThisWorkbook.Sheets("Tümİmalat").Select
    Application.ScreenUpdating = True
    Sheets("Kaynak").Select
    Range("A1").Select
    MsgBox dosyasay & " adet dosyadaki bilgiler programa aktarıldı."
End Sub
 
C

cengizyener

Altın Üye
Katılım
10 Kasım 2022
Mesajlar
27
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
10-11-2028
pitchoute hocam merhabalar,

geri dönüşünüz için çok teşekkür ederim kusura bakmayın biraz geç dönüş yaptım aşağıdaki kodunuzu denedim ve tam istediğim sonucu elde ettim çok teşekkür ederim emeğinize sağlık :)



pitchoute' Alıntı:
Merhaba, deneyip sonucu paylaşabilir misiniz;

Kod: 
Sub Dosyalarin_bulundugu_klasoru_sec()
    Dim kaynak As String
    'aşağıdaki yeşil renkli kodlar klasörün seçim yapılarak alınması için kullanılacak kodlardır.     
    'Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Dosyalarin bulundugu Klasoru Secin", 50, &H0)
    'If Not Klasor Is Nothing Then 
    [BM1].Clear
    kaynak = "\\192.168.1.201\uretim\ÜRETİM RAPORLARI"
    [BM1] = kaynak
   'End If
End Sub

Sub Birlestir()
    Sheets("Tümİmalat").Select
    Range("A5:AC65536").ClearContents
    Dosyalarin_bulundugu_klasoru_sec
    Application.ScreenUpdating = False
    If [BM1] = "" Then End
    Dim t As Integer, dosyasay As Integer
    Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object
    Dim sonsatir As Long, sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
    Dim wb As Workbook
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.getfolder([BM1]).Files
    dosyasay = 0
    ThisWorkbook.Activate
    ThisWorkbook.Sheets("Tümİmalat").Select
    For Each fls In f
        If fso.GetExtensionName(fls) = "xlsm" And Left(fls.Name, 2) <> "~$" Then
            On Error Resume Next
            Set wb = Workbooks.Open(fls.Path, ReadOnly:=True)
            If wb Is Nothing Then
                On Error GoTo 0
                GoTo SonrakiDosya
            End If
            On Error GoTo 0
            With wb
                sonsat1 = .Sheets("Üretim Listesi").Cells(.Sheets("Üretim Listesi").Rows.Count, "F").End(xlUp).Row
                If sonsat1 > 4 Then
                    liste = .Sheets("Üretim Listesi").Range("A5:AC" & sonsat1).Value
                    sonsat2 = ThisWorkbook.Sheets("Tümİmalat").Cells(ThisWorkbook.Sheets("Tümİmalat").Rows.Count, "B").End(xlUp).Row + 1
                    ThisWorkbook.Sheets("Tümİmalat").Range("A" & sonsat2).Resize(UBound(liste, 1), UBound(liste, 2)).Value = liste
                    Erase liste
                End If
            End With
            dosyasay = dosyasay + 1
            wb.Close False
        End If
SonrakiDosya:
    Next fls
    ThisWorkbook.Activate
    ThisWorkbook.Sheets("Tümİmalat").Select
    Application.ScreenUpdating = True
    Sheets("Kaynak").Select
    Range("A1").Select
    MsgBox dosyasay & " adet dosyadaki bilgiler programa aktarıldı."
End Sub
Genişletmek için tıkla ...
 
C

cengizyener

Altın Üye
Katılım
10 Kasım 2022
Mesajlar
27
Excel Vers. ve Dili
Office 365
Altın Üyelik Bitiş Tarihi
10-11-2028
Trilenium hocam merhabalar,

hocam sizin kodu deneyemedim çünkü dosyada çok fazla kod olduğundan benimde makro bilgi pek iyi olmadığı için başka yerlerde ne gibi revize yapacağımı bilmediğim için sizin kodu kullanamıyorum. Size çok teşekkür ederim emeğinize sağlık :)

Trilenium' Alıntı:
Sub AktarVeriler()
Dim wsVeri As Worksheet
Dim wsRapor As Worksheet
Dim lastRow As Long
Dim raporRow As Long
Dim i As Long
Dim hesapAdi As String
Dim fso As Object
Dim f As Object
Dim fls As Object
Dim dosyasay As Long

' FileSystemObject için referans ayarı
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("klasor_yolu").Files ' Klasor_yolu'nu kendi klasör yolunuzla değiştirin

Application.ScreenUpdating = False

' Verilerin aktarılması
For Each fls In f
' dosya türü xlsm olanlardan ve dosya adı 2023 ile başlamayanlardan veri alacak
If fso.GetExtensionName(fls) = "xlsm" And Left(fls.Name, 2) <> "~$" Then
On Error Resume Next ' Hataları yakalamak için
Set wsVeri = Workbooks.Open(fls, ReadOnly:=True).Sheets("Üretim Listesi")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
GoTo NextFile
End If
On Error GoTo 0

' Verileri aktarma işlemi
sonsat1 = wsVeri.Cells(65536, "F").End(xlUp).Row
If sonsat1 > 4 Then
liste = wsVeri.Range("A5:AC" & sonsat1).Value
sonsat2 = ThisWorkbook.Sheets("Tümİmalat").Cells(65536, "B").End(xlUp).Row + 1
ThisWorkbook.Sheets("Tümİmalat").Range("A" & sonsat2).Resize(UBound(liste), 29).Value = liste
Erase liste
End If

Workbooks(fls.Name).Close False
dosyasay = dosyasay + 1
NextFile:
End If
Next fls

ThisWorkbook.Activate
ThisWorkbook.Sheets("Tümİmalat").Select
Application.ScreenUpdating = True
Sheets("Kaynak").Select
Range("A1").Select
MsgBox dosyasay & " adet dosyadaki bilgiler programa aktarildi."
End Sub



şu kod ile deneyebilir misiniz
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst