- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,799
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
O zaman şöyle yapalım sunu sayfası W3 hücresine OK yazınca sunu sayfasındaki bu kod çalışır siz W3 hücresine bir şey yazmayınız ve bu kodu oraya ekleyiniz.
rapor kodunuda bununla değiştir.
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
If ActiveSheet.Cells(4, "W").Value = "OK" Then: Exit Sub
If Intersect(Target, Range("V3")) Is Nothing Then Exit Sub
Sheets("Sunu").Select
yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
Rem aralıktaki resmi sil
Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu
If Dir(yol & Cells(1, "V").Value & ".png") <> "" Then
dosya = Cells(1, "V").Value & ".png"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If
Set s = Sheets("sunu")
If s.[c19] >= 0 And s.[c19] < 150 Then
s.[c2].Font.Name = "Palatino Linotype"
s.[c2].Font.Size = 16
ElseIf s.[c19] >= 150 And s.[c19] < 2000 Then
s.[c2].Font.Name = "Palatino Linotype"
s.[c2].Font.Size = 12
End If
Set s = Sheets("sunu")
s.[b15].HorizontalAlignment = xlJustify 'İKİ YANA YASLI yatay
If s.[b19] >= 0 And s.[b19] < 300 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 26
ElseIf s.[b19] >= 301 And s.[b19] < 400 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 24
ElseIf s.[b19] >= 401 And s.[b19] < 500 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 22
ElseIf s.[b19] >= 501 And s.[b19] < 600 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 20
ElseIf s.[b19] >= 601 And s.[b19] < 700 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 18
ElseIf s.[b19] >= 701 And s.[b19] < 800 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 17
ElseIf s.[b19] >= 801 And s.[b19] < 1000 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 16
ElseIf s.[b19] >= 1001 And s.[b19] < 1200 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 14
ElseIf s.[b19] >= 1201 And s.[b19] < 1400 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 12
ElseIf s.[b19] >= 1401 And s.[b19] < 1600 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 11
ElseIf s.[b19] >= 1601 Then
s.[b15].Font.Name = "Palatino Linotype"
s.[b15].Font.Size = 9
End If
End Sub
Kod:
Public bekle
Sub DIŞARI_RAPOR_SUNU()
MsgBox "EXCEL DOSYASININ OLDUĞU BU DİZİNDE, RAPORLAR VE İÇİNDE DE İHALELER 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("sunu")
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")
yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"
dosya = yol & Cells(1, "V").Value & ".png"
If CreateObject("Scripting.FileSystemObject").FileExists(dosya) = True Then
Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
ActiveSheet.Copy
belge = ThisWorkbook.Path & "\RAPORLAR" & "\İHALELER\" & Replace(Replace(HG.Cells(sat, "T").Value, ":", "="), "/", "&") & ".xlsx"
ActiveWorkbook.SaveAs belge
ActiveWorkbook.Close
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
bitir = Timer
MsgBox "İhalelelerin Dışarı aktarımı " & Format(bitir - basla, "Fixed") & " saniyede Tamamlandı", vbInformation
End Sub
Son düzenleme: