DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), dc As Object
Dim j As Byte, son As Long, i As Long, say As Long
Set s1 = Sheets("ARAMA")
Set s2 = Sheets("MUAVİN")
Set dc = CreateObject("scripting.dictionary")
For j = 2 To 8
If Not s1.Cells(j, 3) = "" Then dc(s1.Cells(j, 3)) = ""
Next j
If dc.Count > 0 Then
son = s2.Cells(Rows.Count, 1).End(xlUp).Row
If son > 1 Then
a = s2.Range("A1:I" & son).Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 2 To UBound(a)
If a(i, 2) = 1 Then
If Not dc.exists(a(i, 3)) Then
say = say + 1
For j = 1 To UBound(a, 2)
b(say, j) = a(i, j)
Next j
End If
End If
Next i
End If
End If
s1.Range("B11:J" & Rows.Count) = ""
s1.Range("B11:J" & Rows.Count).ClearFormats
If say > 0 Then
s1.[B11].Resize(say).NumberFormat = "dd.mm.yyyy"
s1.[I11].Resize(say, 2).NumberFormat = "#,##0.00"
s1.[B11].Resize(say, 9) = b
s1.[B11].Resize(say, 9).Borders.Weight = xlThin
End If
MsgBox "işlem bitti.", vbInformation
End SubOption Explicit
Sub Ara_Bul_Listele_Dizi_Yontemi()
Dim S1 As Worksheet, S2 As Worksheet, Hesap_Kodu As Object
Dim Son As Long, Veri As Variant, X As Long
Dim Y As Byte, Say As Long, Zaman As Double
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set S1 = Sheets("MUAVİN")
Set S2 = Sheets("ARAMA")
Set Hesap_Kodu = CreateObject("Scripting.Dictionary")
S2.Range("A11:J" & S2.Rows.Count).Clear
Veri = S2.Range("C2:C8").Value
For X = LBound(Veri, 1) To UBound(Veri, 1)
If Veri(X, 1) <> "" Then Hesap_Kodu.Item(Veri(X, 1)) = 1
Next
Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
If Son = 2 Then Son = 3
Veri = S1.Range("A2:I" & Son).Value
ReDim Liste(1 To UBound(Veri, 1), 1 To UBound(Veri, 2))
For X = LBound(Veri, 1) To UBound(Veri, 1)
If Veri(X, 3) <> "" Then
If Hesap_Kodu.Exists(Veri(X, 3)) Then
Say = Say + 1
For Y = 1 To 9
Liste(Say, Y) = Veri(X, Y)
Next
End If
End If
Next
With S2.Range("B11")
.Resize(Say, 9) = Liste
.Resize(Say, 9).Borders.LineStyle = 1
.Resize(Say).NumberFormat = "dd.mm.yyyy"
.Offset(, 7).Resize(Say, 2).NumberFormat = "#,##0.00"
End With
Set S1 = Nothing
Set S2 = Nothing
Set Hesap_Kodu = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End SubOption Explicit
Sub Ara_Bul_Listele_Ado_Yontemi()
Dim Dosya As String, Zaman As Double, S1 As Worksheet
Dim Kod As Range, Kodlar As String, Sorgu As String
Dim Kayit_Seti As Object, Baglanti As Object
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Baglanti = CreateObject("AdoDb.Connection")
Set Kayit_Seti = CreateObject("AdoDb.Recordset")
Set S1 = Sheets("ARAMA")
Dosya = ThisWorkbook.FullName
S1.Range("B11:J" & S1.Rows.Count).Clear
For Each Kod In S1.Range("C2:C8")
If Kod.Value <> "" Then
Kodlar = IIf(Kodlar = "", Kod.Value, Kodlar & "," & Kod.Value)
End If
Next
Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
Sorgu = "Select * From [MUAVİN$A2:I] Where F3 In (" & Kodlar & ")"
Kayit_Seti.Open Sorgu, Baglanti, 1, 1
If Kayit_Seti.RecordCount > 0 Then
S1.Range("B11").CopyFromRecordset Kayit_Seti
S1.Range("B11").Resize(Kayit_Seti.RecordCount, 9).Borders.LineStyle = 1
S1.Range("B11").Resize(Kayit_Seti.RecordCount).NumberFormat = "dd.mm.yyyy"
S1.Range("I11").Resize(Kayit_Seti.RecordCount, 2).NumberFormat = "#,##0.00"
S1.Columns.AutoFit
End If
If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
If Baglanti.State <> 0 Then Baglanti.Close
Set Kayit_Seti = Nothing
Set Baglanti = Nothing
Set S1 = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End SubSub Ara_Bul_Listele()
Dim S1 As Worksheet, S2 As Worksheet, Hesap_Kodu As Object, Madde_No As Object, Hesap_No_Kontrol As Variant
Dim Son_Muavin As Long, Veri_Muavin As Variant, X As Long, Kontrol As Boolean, Kod_Say As Integer
Dim Aranan_Hesaplar As Variant, Ana_Hesaplar As Variant, Y As Byte, Say As Long, Zaman As Double
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set S1 = Sheets("MUAVİN")
Set S2 = Sheets("ARAMA")
Set Hesap_Kodu = CreateObject("Scripting.Dictionary")
Set Madde_No = CreateObject("Scripting.Dictionary")
S2.Range("A11:J" & S2.Rows.Count).Clear
Son_Muavin = S1.Cells(S1.Rows.Count, 1).End(3).Row
If Son_Muavin = 2 Then Son_Muavin = 3
Veri_Muavin = S1.Range("A2:I" & Son_Muavin).Value
For X = LBound(Veri_Muavin, 1) To UBound(Veri_Muavin, 1)
If Veri_Muavin(X, 3) <> "" Then
If Not Madde_No.Exists(Veri_Muavin(X, 2)) Then
Say = Say + 1
Madde_No.Add Veri_Muavin(X, 2), Array(Say, Veri_Muavin(X, 3))
Else
Ana_Hesaplar = Split(Madde_No.Item(Veri_Muavin(X, 2))(1), " ")
For Y = LBound(Ana_Hesaplar) To UBound(Ana_Hesaplar)
If Ana_Hesaplar(Y) = CStr(Veri_Muavin(X, 3)) Then
Kontrol = True
Exit For
End If
Next
If Kontrol = False Then
Madde_No.Item(Veri_Muavin(X, 2)) = Array(Madde_No.Item(Veri_Muavin(X, 2))(0), Madde_No.Item(Veri_Muavin(X, 2))(1) & " " & Veri_Muavin(X, 3))
End If
Kontrol = False
End If
End If
Next
Ana_Hesaplar = S2.Range("C2:C8").Value
ReDim Liste(1 To UBound(Ana_Hesaplar, 1), 1 To UBound(Ana_Hesaplar, 2))
For X = LBound(Ana_Hesaplar, 1) To UBound(Ana_Hesaplar, 1)
If Ana_Hesaplar(X, 1) <> "" Then Hesap_Kodu.Item(CStr(Ana_Hesaplar(X, 1))) = 1
Next
ReDim Liste(1 To UBound(Veri_Muavin, 1), 1 To UBound(Veri_Muavin, 2))
Say = 0
For X = LBound(Veri_Muavin, 1) To UBound(Veri_Muavin, 1)
If Veri_Muavin(X, 3) <> "" Then
If Madde_No.Exists(Veri_Muavin(X, 2)) Then
Hesap_No_Kontrol = Split(Madde_No.Item(Veri_Muavin(X, 2))(1), " ")
If UBound(Hesap_No_Kontrol) + 1 = Hesap_Kodu.Count Then
For Y = LBound(Hesap_No_Kontrol) To UBound(Hesap_No_Kontrol)
If Hesap_Kodu.Exists(Hesap_No_Kontrol(Y)) Then
Kod_Say = Kod_Say + 1
End If
Next
If Kod_Say = Hesap_Kodu.Count Then
Say = Say + 1
For Y = 1 To 9
Liste(Say, Y) = Veri_Muavin(X, Y)
Next
End If
Kod_Say = 0
End If
End If
End If
Next
If Say > 0 Then
With S2.Range("B11")
.Resize(Say, 9) = Liste
.Resize(Say, 9).Borders.LineStyle = 1
.Resize(Say).NumberFormat = "dd.mm.yyyy"
.Offset(, 7).Resize(Say, 2).NumberFormat = "#,##0.00"
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
Else
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Aranan ana hesaplara ait kayıt bulunamadı!" & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbCritical
End If
Set S1 = Nothing
Set S2 = Nothing
Set Hesap_Kodu = Nothing
Set Madde_No = Nothing
End Sub