DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub aktar59()
Dim sonsat As Long, i As Long
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
If sonsat < 4 Then Exit Sub
Range("P4:P" & Rows.Count).ClearContents
For i = 4 To sonsat
If Dir(ThisWorkbook.Path & "\" & Cells(i, "B").Value & ".xlsm") = "" Then
MsgBox Cells(i, "B").Value & ".xlsm" & vbLf & "Adlı dosya bulunamadı.", vbCritical, "DOSYA YOK"
GoTo atla
End If
Cells(i, "P").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & _
"\[" & Cells(i, "B").Value & ".xlsm]GENEL'!R9C12")
Cells(i, "Q").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & _
"\[" & Cells(i, "B").Value & ".xlsm]GENEL'!R10C12")
Cells(i, "R").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & _
"\[" & Cells(i, "B").Value & ".xlsm]GENEL'!R10C13")
Cells(i, "T").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & _
"\[" & Cells(i, "B").Value & ".xlsm]GENEL'!R11C12")
Cells(i, "U").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & _
"\[" & Cells(i, "B").Value & ".xlsm]GENEL'!R11C13")
Cells(i, "W").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & _
"\[" & Cells(i, "B").Value & ".xlsm]GENEL'!R12C12")
Cells(i, "X").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & _
"\[" & Cells(i, "B").Value & ".xlsm]GENEL'!R12C13")
atla:
Next i
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
aynı şekilde ödenek tutarı, harcanan tutar, kalan tutar (proje ve seyahat olarak) hanelerini de aktarabilir miyiz?:yardim:
2 nolu mesajda dosyayı güncelledim.![]()
Rica ederim.Üstad Orion1,
Tam istediğim gibi olmuş. Zahmetin ve emeğin için çok teşekkür ederim. Ellerin dert görmesin.:dua::dua2:
Kolay gelsin.