eklenen resimlerin başka pc de çıkmaması

Katılım
25 Ocak 2006
Mesajlar
764
Excel Vers. ve Dili
2019 tr
Altın Üyelik Bitiş Tarihi
04-01-2024
makro ile oluşturulan kod ile sayfaya resim çağırıyorum ve bunları daha sonra başka bir çalışma sayfasına çıkarıyorum. bu şekilde yaptığımda başka kişilere gönderdiğimde resim onlarda çıkmıyor. bunu nasıl aşarım.
tek tek çıkarttığım excel dosyalarının kodu
Kod:
Public bekle
Sub DIŞARI_SERVİSLERE_KOORO()
Set HG = Sheets("HÜCRE GİRİŞ"): Set Ko = Sheets("kooro")
bekle = "DUR"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For sat = 1 To HG.Cells(Rows.Count, "aU").End(3).Row
    If HG.Cells(sat, "aU").Value <> "" Then
        Ko.[V3] = HG.Cells(sat, "aT")
        ActiveSheet.Copy
        belge = ThisWorkbook.Path & "\RAPORLAR" & "\SERVİSLER" & "\KOORO" & "\" & Ko.[V14].Value & "\" & Replace(Replace(HG.Cells(sat, "AU").Value, ":", "="), "/", "&") & ".xlsx"
        ActiveWorkbook.SaveAs belge
        ActiveWorkbook.Close
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
MsgBox Ko.[V14].Value & " Servisinin Dışa Aktarımı Tamamlandı", vbInformation
End Sub
bu şekilde burada sürekli v3 değeri değişerek resimler geldiği için bu işlemin de bozulmaması gerekli.

daha sonra klasörler içindeki excelleri aşağıdaki kod ile birleştiriyorum. burada belki sorunumu aşmamda yardımcı olabilirsiniz.
Kod:
Public Fso As Object, Evn As Object, Dosya As Object
Public Klasörler As Object, Sat As Long

Sub Dizindeki_Tüm_Klasörleri_Tara()
On Error Resume Next
MsgBox "BİRLEŞTİRME İÇİN, BU DOSYANIN OLDUĞU DİZİNDE (İLLER) ADLI KLASÖRÜN OLMALI", vbExclamation, "FIRAT UYARIYOR!"
MsgBox "BU KALSÖRÜN İÇİNDE DE, 6 İL İÇİN AYRI AYRI KLASÖRÜN OLMALI VE EXCEL DOSYALARIN BU KLASÖRDE OLMALI ", vbExclamation, "FIRAT UYARIYOR!"
Secim = MsgBox("BU ŞARTLAR SAĞLANDI MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDELİM O HALDE!", vbMsgBoxSetForeground
Exit Sub
End If
    Call Ara(ThisWorkbook.Path)
    Set Fso = Nothing: Set Evn = Nothing: Sat = Empty
    Set Dosya = Nothing: Set Klasörler = Nothing
End Sub

Public Function Ara(ByVal Dizin As String)
On Error Resume Next
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Evn = Fso.GetFolder(Dizin): Ara = 0
    For Each Klasörler In Evn.Subfolders
        For Each Dosya In Klasörler.Files
            If Right(Dosya.Name, 5) = ".xlsx" Then
                Workbooks.Open Filename:=Dosya, ReadOnly:=True
                For Each Sheet In ActiveWorkbook.Sheets
                    ActiveSheet.Name = ActiveSheet.Range("v1")
                    Sheet.Copy After:=ThisWorkbook.Sheets(1)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
                Next Sheet
                Workbooks(Dosya.Name).Close
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
            End If
        Next Dosya
        Ara = Ara + 1 + Ara(Klasörler.Path)
    Next Klasörler
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False


End Function
sanırım 2. kodda, yani birleştirdiğim kodda tüm bağlantıları kesecek şekilde bir kod eklemem gerekiyor. resimler duracak şekilde tabi
 
Son düzenleme:
Üst