- Katılım
- 25 Ocak 2006
- Mesajlar
- 763
- Excel Vers. ve Dili
- 2019 tr
- Altın Üyelik Bitiş Tarihi
- 04-01-2024
Kod:
Public bekle
Sub DIŞARI_FORMFRT()
MsgBox "EXCEL DOSYASININ OLDUĞU BU DİZİNDE, RAPORLAR VE İÇİNDE DE FORMFRT ADLI KLASÖRÜN 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 EDEYİM BARİ!", vbMsgBoxSetForeground
Exit Sub
End If
Dim basla, bitir, süre
Dim i As Long
basla = Timer
Set HG = Sheets("HÜCRE GİRİŞ"): Set s = Sheets("FORMFRT")
bekle = "DUR"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xy = InputBox("KAÇ İHALE RAPORLANACAK. YAZ. GT DEKİ SIRALAMA")
If xy = "" Then
MsgBox "yazmadın, çıkıyorum...", vbInformation, " Uyarı"
Exit Sub
End If
For sat = 1 To xy
s.[V3] = HG.Cells(sat, "Q")
ActiveSheet.Copy
belge = ThisWorkbook.Path & "\RAPORLAR" & "\FORMFRT\" & Replace(Replace(HG.Cells(sat, "aa").Value, ":", "="), "/", "&") & ".xlsx"
Columns("U:AH").Select
Selection.EntireColumn.Hidden = True
Rows("41:41").Select
Selection.EntireRow.Hidden = True
Range("C2").Activate
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
'bu kod linkleri kesiyor.
End If
ActiveWorkbook.SaveAs belge
ActiveWorkbook.Close
Next
For sat = 1 To HG.Cells(Rows.Count, "AK").End(3).Row
If HG.Cells(sat, "AK").Value <> "" Then
s.[V3] = HG.Cells(sat, "AI")
ActiveSheet.Copy
belge = ThisWorkbook.Path & "\RAPORLAR" & "\FORMFRT\" & Replace(Replace(HG.Cells(sat, "aK").Value, ":", "="), "/", "&") & ".xlsx"
Columns("U:AH").Select
Selection.EntireColumn.Hidden = True
Rows("41:41").Select
Selection.EntireRow.Hidden = True
Range("C2").Activate
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
'bu kod linkleri kesiyor.
End If
ActiveWorkbook.SaveAs belge
ActiveWorkbook.Close
End If
Next
bekle = ""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
bitir = Timer
MsgBox "İhalelelerin Dışarı aktarımı " & Format(bitir - basla, "Fixed") & " saniyede Tamamlandı", vbInformation
End Sub