- Katılım
- 15 Kasım 2007
- Mesajlar
- 140
- Excel Vers. ve Dili
- OFFICE 2019 TR 64 Bit
- Altın Üyelik Bitiş Tarihi
- 13.01.2022
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 3 Then
s1.Range("A4:V" & eski).ClearContents
s1.Range("A4:V" & eski).Interior.Color = xlNone
s1.Range("A4:V" & eski).Borders.LineStyle = xlNone
End If
If Target = "" Then Exit Sub
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
Application.EnableEvents = False
Application.ScreenUpdating = False
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Sheets.Count
If WorksheetFunction.CountIf(s1.Range(Cells(1, "A"), Cells(1, sonsut)), Sheets(i).Name) > 0 Then
son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), Target) > 0 Then
yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
Sheets(i).[A2:V2].Copy s1.Cells(yeni, "A")
sorgu = "select * from[" & Sheets(i).Name & "$B2:V" & son & "] where F1='" & Target & "'"
Set rs = con.Execute(sorgu)
s1.Range("B" & yeni + 1).CopyFromRecordset rs
End If
End If
Next
enson = s1.Cells(Rows.Count, "B").End(3).Row
a = 1
If enson > 3 Then
For j = 4 To enson
If s1.Cells(j, "B") = Target Then
s1.Cells(j, "A") = a
a = a + 1
Else
sonsut = s1.Cells(j, Columns.Count).End(xlToLeft).Column
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Borders.Color = vbRed
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Interior.Color = vbBlue
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Color = vbWhite
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Bold = True
End If
Next
End If
Columns("A:V").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 3 Then
s1.Range("A4:V" & eski).ClearContents
s1.Range("A4:V" & eski).Interior.Color = xlNone
s1.Range("A4:V" & eski).Borders.LineStyle = xlNone
End If
If Target = "" Then Exit Sub
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
Application.EnableEvents = False
Application.ScreenUpdating = False
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Sheets.Count
If WorksheetFunction.CountIf(s1.Range(Cells(1, "A"), Cells(1, sonsut)), Sheets(i).Name) > 0 Then
son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), Target) > 0 Then
yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
Sheets(i).[A2:V2].Copy s1.Cells(yeni, "A")
sorgu = "select * from[" & Sheets(i).Name & "$B2:V" & son & "] where F1='" & Target & "'"
Set rs = con.Execute(sorgu)
s1.Range("B" & yeni + 1).CopyFromRecordset rs
End If
End If
sonsut = s1.Cells(yeni, Columns.Count).End(xlToLeft).Column
If WorksheetFunction.CountIf(Range(Cells(yeni, "A"), Cells(yeni, sonsut)), "TARIH") > 0 Then
enson = s1.Cells(Rows.Count, "B").End(3).Row
sut = WorksheetFunction.Match("TARIH", s1.Range(Cells(yeni, "A"), Cells(yeni, sonsut)), 0)
Range(Cells(yeni, sut), Cells(enson, sut)).NumberFormat = "dd/mm/yyyy"
End If
Next
enson = s1.Cells(Rows.Count, "B").End(3).Row
a = 1
If enson > 3 Then
For j = 4 To enson
sonsut = s1.Cells(j, Columns.Count).End(xlToLeft).Column
If s1.Cells(j, "B") = Target Then
s1.Cells(j, "A") = a
a = a + 1
Else
If j > 4 Then Cells(j, "A").ClearContents
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Borders.Color = vbRed
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Interior.Color = vbBlue
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Color = vbWhite
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Bold = True
End If
Next
End If
Range("B4:B" & enson).Delete shift:=xlToLeft
Range("A4:A" & enson).HorizontalAlignment = xlCenter
Columns("A:U").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 3 Then
s1.Range("A4:V" & eski).ClearContents
s1.Range("A4:V" & eski).Interior.Color = xlNone
s1.Range("A4:V" & eski).Borders.LineStyle = xlNone
End If
If Target = "" Then Exit Sub
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
Application.EnableEvents = False
Application.ScreenUpdating = False
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, "A"), Cells(1, sonsut)).Interior.Color = xlNone
For i = 1 To Sheets.Count
If WorksheetFunction.CountIf(s1.Range(Cells(1, "A"), Cells(1, sonsut)), Sheets(i).Name) > 0 Then
son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), Target) > 0 Then
yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
Sheets(i).[A2:V2].Copy s1.Cells(yeni, "A")
sorgu = "select * from[" & Sheets(i).Name & "$B2:V" & son & "] where F1='" & Target & "'"
Set rs = con.Execute(sorgu)
s1.Range("B" & yeni + 1).CopyFromRecordset rs
sonsut = s1.Cells(yeni, Columns.Count).End(xlToLeft).Column
If WorksheetFunction.CountIf(Range(Cells(yeni, "A"), Cells(yeni, sonsut)), "TARIH") > 0 Then
enson = s1.Cells(Rows.Count, "B").End(3).Row
sut = WorksheetFunction.Match("TARIH", s1.Range(Cells(yeni, "A"), Cells(yeni, sonsut)), 0)
Range(Cells(yeni, sut), Cells(enson, sut)).NumberFormat = "dd/mm/yyyy"
End If
End If
End If
Next
enson = s1.Cells(Rows.Count, "B").End(3).Row
a = 1
If enson > 3 Then
For j = 4 To enson
sonsut = s1.Cells(j, Columns.Count).End(xlToLeft).Column
If s1.Cells(j, "B") = Target Then
s1.Cells(j, "A") = a
a = a + 1
Else
If j > 4 Then Cells(j, "A").ClearContents
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Borders.Color = vbRed
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Interior.Color = vbBlue
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Color = vbWhite
s1.Range(Cells(j, "A"), Cells(j, sonsut)).Font.Bold = True
End If
Next
End If
sonsut = s1.Cells(1, Columns.Count).End(xlToLeft).Column
For m = 1 To sonsut
sayfa = "Yok"
For n = 1 To Sheets.Count
If Sheets(n).Name = Cells(1, m) Then
sayfa = "Var"
End If
Next
If sayfa = "Yok" Then
Cells(1, m).Interior.Color = vbRed
End If
Next
Range("B4:B" & enson).Delete shift:=xlToLeft
Range("A4:A" & enson).HorizontalAlignment = xlCenter
Columns("A:U").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1:D1]) Is Nothing Then Exit Sub
Set s1 = ActiveSheet
eski = s1.Cells(Rows.Count, "B").End(3).Row
If eski > 2 Then
s1.Range("A3:N" & eski).ClearContents
End If
If Target = "" Then Exit Sub
kisi = [B1].Value
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
Application.EnableEvents = False
Application.ScreenUpdating = False
sat = 3
For i = 1 To Sheets.Count
If Sheets(i).Name = "Yazlık" Or Sheets(i).Name = "Kışlık" Or Sheets(i).Name = "Tohum" Or _
Sheets(i).Name = "Gübre" Or Sheets(i).Name = "Sulama" Then
son = Sheets(i).Cells(Rows.Count, "B").End(3).Row
If WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), kisi) > 0 Then
say = WorksheetFunction.CountIf(Sheets(i).Range("B1:B" & son), kisi)
sorgu = "select F6,F7,F8,F9,F10,F11,F12,F13,F14,F15,F16,F17,F18 from[" & Sheets(i).Name & "$A2:R" & son & "] where F2='" & kisi & "'"
Set rs = con.Execute(sorgu)
s1.Range("B" & sat).CopyFromRecordset rs
sat = sat + say
End If
End If
Next
For j = 3 To sat - 1
s1.Cells(j, "A") = j - 2
Next
s1.Columns("A:N").EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "İşlem tamamlandı!", vbExclamation
End Sub