DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub AKTAR()
Dim S1 As Worksheet, S2 As Worksheet, SATIR As Long
Set S1 = Sheets("VERİ GİRİŞ")
Set S2 = Sheets("DATA")
SATIR = S2.Range("A65536").End(3).Row + 1
S2.Cells(SATIR, "A") = CDate(S1.Range("D2"))
S1.Range("D3:D" & S1.Range("A65536").End(3).Row).Copy
S2.Cells(SATIR, "C").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
S2.Select
Range("A1").Select
Set S1 = Nothing
Set S2 = Nothing
ActiveWorkbook.Save
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Private Sub CommandButton2_Click()
Dim S1 As Worksheet, S2 As Worksheet, X As Byte
Dim Ayın_İlk_Günü As Date, Yılın_İlk_Günü As Date
Set S1 = Sheets("DATA")
Set S2 = Sheets("RAPORLAMA")
S2.Select
If S2.Range("D4") = "" Then
MsgBox "Lütfen tarih seçiniz !", vbCritical
Range("D4").Select
Exit Sub
End If
Application.ScreenUpdating = False
S2.Range("D5:F78").ClearContents
Range("E4") = Format(Range("D4"), "mmmm")
Range("F4") = Format(Range("D4"), "yyyy")
If S1.AutoFilterMode = False Then S1.Rows("2:2").AutoFilter
S1.Range("$A$2:$IU$65536").AutoFilter Field:=1, Criteria1:=Format(Range("D4"), "dd.mm.yyyy")
S1.Calculate
For X = 5 To Range("A65536").End(3).Row
If S1.Cells(2, X - 2) = Cells(X, 2) Then
Cells(X, 4) = S1.Cells(3, X - 2)
End If
Next
If S1.AutoFilterMode = False Then S1.Rows("2:2").AutoFilter
Ayın_İlk_Günü = DateSerial(Year(Range("D4")), Month(Range("D4")), 1)
S1.Range("$A$2:$IU$65536").AutoFilter Field:=1, Criteria1:=">=" & CLng(Ayın_İlk_Günü), Operator:=xlAnd, Criteria2:="<=" & CLng(Range("D4"))
S1.Calculate
For X = 5 To Range("A65536").End(3).Row
If S1.Cells(2, X - 2) = Cells(X, 2) Then
Cells(X, 5) = S1.Cells(3, X - 2)
End If
Next
If S1.AutoFilterMode = False Then S1.Rows("2:2").AutoFilter
Yılın_İlk_Günü = DateSerial(Year(Range("D4")), 1, 1)
S1.Range("$A$2:$IU$65536").AutoFilter Field:=1, Criteria1:=">=" & CLng(Yılın_İlk_Günü), Operator:=xlAnd, Criteria2:="<=" & CLng(Range("D4"))
S1.Calculate
For X = 5 To Range("A65536").End(3).Row
If S1.Cells(2, X - 2) = Cells(X, 2) Then
Cells(X, 6) = S1.Cells(3, X - 2)
End If
Next
S1.Rows("2:2").AutoFilter
Set S1 = Nothing
Set S2 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub