DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub duzenle()
Dim aSon As Integer, lst1, w()
Set sf1 = Sheets("FaturaArsiv")
With sf1
aSon = .Cells(Rows.Count, "A").End(xlUp).Row
lst1 = .Range(.Cells(2, "A"), .Cells(aSon, "G"))
ReDim w(1 To aSon - 1, 1 To 9)
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(lst1)
Key = Trim(lst1(i, 1))
If Not .Exists(Key) Then
say = say + 1
w(say, 1) = lst1(i, 1)
w(say, 2) = lst1(i, 2)
w(say, 3) = lst1(i, 3)
.Add Key, say
End If
say = .Item(Key)
Select Case Left(lst1(i, 4), 6)
Case ("İŞ GÜV"): SUT = 4
Case ("İŞYERİ"): SUT = 6
Case ("D. SAĞ"): SUT = 8
End Select
For ii = 4 To 16
w(say, SUT) = lst1(i, 5)
w(say, SUT + 1) = lst1(i, 7)
Next ii
Next i
say = .Count
End With
[K3].Resize(say, 9).Value = w
Set sf1 = Nothing
Erase lst1, w
End SubSub kod()
Application.ScreenUpdating = False
Dim S1 As Worksheet: Set S1 = Sheets("Sayfa1")
Dim S2 As Worksheet: Set S2 = Sheets("FaturaArsiv")
Dim WF As WorksheetFunction: Set WF = Application.WorksheetFunction
S1.Range("A3:I" & Rows.Count).ClearContents
sonsatır = S2.Cells(Rows.Count, "A").End(3).Row
seçim = Array("", "İŞ GÜVENLİĞİ UZMANI HİZMET BEDELİ", "İŞYERİ HEKİMİ HİZMET BEDELİ", "D. SAĞLIK PRS. HİZMET BEDELİ")
sat = 3
For i = 2 To sonsatır
If WF.CountIf(S2.Range("A2" & ":A" & i), S2.Cells(i, "A")) = 1 Then
S1.Cells(sat, "A") = S2.Cells(i, "A")
S1.Cells(sat, "B") = S2.Cells(i, "B")
S1.Cells(sat, "C") = S2.Cells(i, "C")
S1.Cells(sat, "D") = WF.SumIfs(S2.Range("E2:E" & sonsatır), S2.Range("A2:A" & sonsatır), S2.Cells(i, "A"), S2.Range("D2:D" & sonsatır), seçim(1))
S1.Cells(sat, "E") = WF.SumIfs(S2.Range("G2:G" & sonsatır), S2.Range("A2:A" & sonsatır), S2.Cells(i, "A"), S2.Range("D2:D" & sonsatır), seçim(1))
S1.Cells(sat, "F") = WF.SumIfs(S2.Range("E2:E" & sonsatır), S2.Range("A2:A" & sonsatır), S2.Cells(i, "A"), S2.Range("D2:D" & sonsatır), seçim(2))
S1.Cells(sat, "G") = WF.SumIfs(S2.Range("G2:G" & sonsatır), S2.Range("A2:A" & sonsatır), S2.Cells(i, "A"), S2.Range("D2:D" & sonsatır), seçim(2))
S1.Cells(sat, "H") = WF.SumIfs(S2.Range("E2:E" & sonsatır), S2.Range("A2:A" & sonsatır), S2.Cells(i, "A"), S2.Range("D2:D" & sonsatır), seçim(3))
S1.Cells(sat, "I") = WF.SumIfs(S2.Range("G2:G" & sonsatır), S2.Range("A2:A" & sonsatır), S2.Cells(i, "A"), S2.Range("D2:D" & sonsatır), seçim(3))
sat = sat + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox "B i t t i "
End Subhttp://www.dosya.tc/server7/oupa96/CEK_TESBIT.rar.html
. . .
Sub KOD()
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, "C").End(3).Row
If Cells(i, "E") = "" And Cells(i, "F") <> "" And Cells(i, "G") = "" Then
Cells(i, "G") = Cells(i - 1, "G")
End If
Next i
i = Empty
For i = Cells(Rows.Count, "C").End(3).Row To 2 Step -1
If Cells(i, "E") <> "" And Cells(i, "F") = "" And Cells(i, "G") = "" Then
Cells(i, "G") = Cells(i + 1, "G")
End If
Next i
i = Empty
Application.ScreenUpdating = True
MsgBox "B i t t i "
End Sub