- Katılım
- 18 Ağustos 2007
- Mesajlar
- 22,183
- Excel Vers. ve Dili
- Microsoft 365 Tr
Ofis 2016 Tr
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim ad As String, syf As Worksheet, i As Long, j As Integer, k As Integer, bul As Long
Dim c As Range, Adr As String, sut As Integer, sat As Long, Sd As Worksheet, doviz
Set Sd = Sheets("DÖVİZ_KURU")
ad = ActiveSheet.Name
Application.ScreenUpdating = False
If IsNumeric(Left(ad, 1)) = True Then
sut = Cells(6, Columns.Count).End(xlToLeft).Column - 1
sat = Cells(Rows.Count, "A").End(xlUp).Row - 1
Set syf = Sheets("" & Split(ad, "_")(1) & "")
Range(Cells(7, 2), Cells(sat, sut)).ClearContents
For i = 7 To sat Step 2
With syf.Range("B:B")
Set c = .Find(Cells(i, "A"), , xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
For j = 2 To sut
If syf.Cells(c.Row, "C") = Cells(6, j) And _
Format(syf.Cells(c.Row, "A"), "mmmm") = Format(Range("B2"), "mmmm") Then
Cells(i, j) = Cells(i, j) + syf.Cells(c.Row, "E")
Cells(i, j).NumberFormat = "#,##0.00 TL"
bul = WorksheetFunction.Match(Format(Range("B2"), "mmmm"), Sd.[A:A], 0)
If Sd.Cells(bul, "B") = "" Then
doviz = 1
Else
doviz = Sd.Cells(bul, "B")
End If
Cells(i + 1, j) = Cells(i + 1, j) + (syf.Cells(c.Row, "E") / doviz)
Cells(i + 1, j).NumberFormat = "[$$-409]#,##0.00"
End If
Next j
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
Next i
Else
If Split(ad, "_")(0) <> "GENEL" Then Exit Sub
sut = Cells(3, Columns.Count).End(xlToLeft).Column - 5
sat = Cells(Rows.Count, "A").End(xlUp).Row - 1
Set syf = Sheets("" & Split(ad, "_")(1) & "")
Range(Cells(4, 2), Cells(sat, sut)).ClearContents
For i = 4 To sat Step 2
With syf.Range("C:C")
Set c = .Find(Cells(i, "A"), , xlValues, xlWhole)
If Not c Is Nothing Then
Adr = c.Address
Do
k = 2
For j = 2 To sut
If j <> 2 And (j - 2) Mod 3 = 0 Then k = k + 3
If syf.Cells(c.Row, "B") = Cells(3, j) Then
If Format(syf.Cells(c.Row, "A"), "mmmm") = Cells(2, k) Then
Cells(i, j) = Cells(i, j) + syf.Cells(c.Row, "E")
Cells(i, j).NumberFormat = "#,##0.00 TL"
bul = WorksheetFunction.Match(Format(Range("B2"), "mmmm"), Sd.[A:A], 0)
If Sd.Cells(bul, "B") = "" Then
doviz = 1
Else
doviz = Sd.Cells(bul, "B")
End If
Cells(i + 1, j) = Cells(i + 1, j) + (syf.Cells(c.Row, "E") / doviz)
Cells(i + 1, j).NumberFormat = "[$$-409]#,##0.00"
End If
End If
Next j
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
Next i
End If
Set c = Nothing
End Sub