- 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
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.
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
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
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
Son düzenleme: