Modül kodları:
1 - tek veri değişimindeki B2 hücresi değişince çalışacak kod
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("b2")) Is Nothing Then TekVeriAl (Target.Value) 'B2 değişince tetiklenir
End SubSub DiziyeAl()
Dim ShtAna As Worksheet
Dim ShtHdf As Worksheet
Dim RngAna As Range
Set ShtAna = ThisWorkbook.Sheets("IVL")
Set ShtHdf = ThisWorkbook.Sheets("Tum_Sayfa")
Set RngAna = ShtAna.Range("A:A")
Set RngAna = RngAna.Worksheet.Range("A2:" & RngAna.Rows(RngAna.Rows.Count).End(xlUp).Address(0, 0))
SonStr = RngAna.Rows(RngAna.Rows.Count).Row
Set AdrsDz = New Collection
For Each Hucr In RngAna
If Hucr.Font.Bold = True And IsNumeric(Hucr.Value) = True Then
AdrsDz.Add Int(Hucr.Row)
End If
Next Hucr
VeriAlStr = veriAl
RngKopya = ""
HcrYukseklik = ""
For x = 1 To AdrsDz.Count
If InStr(VeriAlStr, ":" & Replace(ShtAna.Range("A" & AdrsDz(x)), ".", "") & ":") > 0 Then
If x = AdrsDz.Count Then RngBit = SonStr Else RngBit = AdrsDz(x + 1) - 2
RngBit = ShtAna.Range("l" & RngBit).End(xlUp).Row + 1
RngKopya = RngKopya & "," & ShtAna.Range("A" & AdrsDz(x)).Address & ":" & ShtAna.Range("O" & RngBit).Address
HcrYukseklik = HcrYukseklik & "," & RngBit
End If
Next x
'hy_____________________________________Sil
With ShtHdf
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row + 10
.Range("A2:O" & LastRow).UnMerge
.Range("A2:O" & LastRow).Clear
.Cells.UseStandardHeight = True
.Cells.UseStandardWidth = True
'hy_____________________________________kopyalama
RngKopya = Mid(RngKopya, 2)
ShtAna.Range(RngKopya).Copy
.Range("D2").PasteSpecial xlPasteAll
For x = 2 To SonStr
If .Range("D" & x).Font.Bold = True And IsNumeric(.Range("D" & x).Value) = True Then
' .Range("D" & x).Copy
' .Range("A" & x).PasteSpecial xlPasteAll
'
' .Range("E" & x).Copy
' .Range("B" & x).PasteSpecial xlPasteAll
' .Range("O" & x).Copy
' .Range("C" & x).PasteSpecial xlPasteAll
.Range("A" & x).Value = .Range("D" & x).Value
.Range("B" & x).Value = .Range("E" & x).Value
.Range("C" & x).Value = .Range("O" & x).Value
.Range("A" & x).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
.Range("B" & x).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
.Range("C" & x).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
End If
Next x
End With
'hy_______________________________________________________
HcrYukseklik = Mid(HcrYukseklik, 2)
YukseklikDizi = Split(HcrYukseklik, ",")
With ShtHdf
SonStr = .Range("D" & .Rows.Count).End(xlUp).Row
y = 0
For x = 3 To SonStr
If .Range("D" & x).Font.Bold = True And IsNumeric(.Range("D" & x).Value) = True Then
.Range("D" & x - 1).RowHeight = ShtAna.Range("O" & YukseklikDizi(y)).RowHeight
y = y + 1
End If
Next x
.Range("D" & SonStr).RowHeight = ShtAna.Range("O" & YukseklikDizi(y)).RowHeight
For x = 1 To 15
.Columns(x + 3).ColumnWidth = ThisWorkbook.Sheets("IVL").Columns(x).ColumnWidth
Next x
.Columns(1).ColumnWidth = 10.14
.Columns(2).ColumnWidth = 105.14
.Columns(3).ColumnWidth = 9.14
.Columns("A:C").Font.Bold = True
.Columns(1).NumberFormat = "#,##0"
End With
Application.CutCopyMode = False
End Sub
Function veriAl() As String
Set Sht = ThisWorkbook.Sheets("Tum_Sayfa")
SonStr = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row
Set Rng = ThisWorkbook.Sheets("Tum_Sayfa").Range("A2:A" & SonStr)
For Each Hucr In Rng
veriAl = veriAl & ":" & Replace(Hucr.Rows, ".", "")
Next Hucr
veriAl = veriAl & ":"
End FunctionSub TekVeriAl(ByVal txtAranan As String) 'TekVeriAl("15.100.1005")
Dim ShtAna As Worksheet
Dim ShtHdf As Worksheet
Dim RngAna As Range
txtAranan = Replace(txtAranan, ".", "")
Set ShtAna = ThisWorkbook.Sheets("IVL")
Set ShtHdf = ThisWorkbook.Sheets("Arama")
Set RngAna = ShtAna.Range("A:A")
Set RngAna = RngAna.Worksheet.Range("A2:" & RngAna.Rows(RngAna.Rows.Count).End(xlUp).Address(0, 0))
SonStr = RngAna.Rows(RngAna.Rows.Count).Row
For Each Hucr In RngAna
If Hucr.Font.Bold = True And IsNumeric(Hucr.Value) = True And Replace(Hucr.Value, ".", "") = txtAranan Then
BasStr = Int(Hucr.Row)
Exit For
End If
Next Hucr
For x = BasStr + 1 To SonStr
If ShtAna.Range("A" & x).Font.Bold = True And IsNumeric(ShtAna.Range("A" & x).Value) = True Then
BitStr = x
Exit For
End If
Next
SonStr = ShtAna.Cells(x - 1, "L").End(xlUp).Row
BitStr = SonStr + 1
Set RngCopy = ShtAna.Range("A" & BasStr & ":O" & BitStr)
With ShtHdf
SonStrHdf = .Cells(.Rows.Count, "C").End(xlUp).Row
.Range("C:Q").EntireColumn.Delete
.Cells.RowHeight = 15
RngCopy.Copy
.Range("C2").PasteSpecial xlPasteAll
For x = 1 To 15
.Columns(x + 2).ColumnWidth = ShtAna.Columns(x).ColumnWidth
Next x
.Columns("A:C").Font.Bold = True
.Columns(1).NumberFormat = "#,##0"
.Range("A" & SonStrHdf).RowHeight = ShtAna.Range("A" & BitStr).RowHeight
End With
Application.CutCopyMode = False
End Sub
