Merhaba birde bu kodu denermisiniz.İki tane modul ekleyelim ve bu modüllere ayrı ayrı sayfa ekleyeceğiz birde sayafa isimlerini sen kendine göre değiştirirsin.
Anasayfaya aşağıdaki kodu ekleyelim.
Kod:
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim SAYFA_ADI As String
Dim BUL As Range, ADRES As String
Dim SATIR As Long
If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
Cancel = True
Cells.EntireColumn.AutoFit
SAYFA_ADI = Target.Text
If SAYFA_ADI = "" Then Exit Sub
If SAYFA(SAYFA_ADI) Then
Set BUL = Columns(3).Find(SAYFA_ADI)
If Not BUL Is Nothing Then
ADRES = BUL.Address
Do
With Sheets(SAYFA_ADI)
SATIR = .[A65536].End(3).Row + 1
.Cells(SATIR, 1) = SATIR - 2
.Cells(SATIR, 2) = Cells(BUL.Row, 2)
.Cells(SATIR, 3) = Cells(BUL.Row, 4)
.Cells(SATIR, 4) = Cells(BUL.Row, 6)
.Cells(SATIR, 5) = Cells(BUL.Row, 7)
.Cells(SATIR, 6) = Cells(BUL.Row, 8)
.Cells(SATIR, 7) = Cells(BUL.Row, 9)
SATIR = SATIR + 1
End With
Set BUL = Columns(3).FindNext(BUL)
Loop While ADRES <> BUL.Address And Not BUL Is Nothing
Sheets(SAYFA_ADI).Cells.EntireColumn.AutoFit
End If
Else
Sheets("ŞABLON").Visible = True
Sheets("ŞABLON").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = SAYFA_ADI
ActiveSheet.[A1] = Target
Set BUL = Columns(3).Find(SAYFA_ADI)
If Not BUL Is Nothing Then
ADRES = BUL.Address
Do
With ActiveSheet
SATIR = .[A65536].End(3).Row + 1
.Cells(SATIR, 1) = SATIR - 2
.Cells(SATIR, 2) = Cells(BUL.Row, 2)
.Cells(SATIR, 3) = Cells(BUL.Row, 4)
.Cells(SATIR, 4) = Cells(BUL.Row, 6)
.Cells(SATIR, 5) = Cells(BUL.Row, 7)
.Cells(SATIR, 6) = Cells(BUL.Row, 8)
.Cells(SATIR, 7) = Cells(BUL.Row, 9)
SATIR = SATIR + 1
End With
Set BUL = Columns(3).FindNext(BUL)
Loop While ADRES <> BUL.Address And Not BUL Is Nothing
Sheets(SAYFA_ADI).Cells.EntireColumn.AutoFit
End If
End If
Sheets("ŞABLON").Visible = False
SAYFALARI_ALFABETİK_SIRALA
Sheets("ANA SAYFA").Select
Set BUL = Nothing
Application.ScreenUpdating = True
MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub
Mödül 1 yazılacak olan kod
Kod:
Option Explicit
Function SAYFA(SAYFAADI As String) As Boolean
On Error Resume Next
SAYFA = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function
Modül 2 yazılacak kod
[/code]
Option Explicit
Sub SAYFALARI_ALFABETİK_SIRALA()
Dim X As Integer, Y As Integer, Say As Integer
Application.ScreenUpdating = False
Sheets(1).Select
Say = Sheets.Count
If Say < 2 Then Exit Sub
Sheets.Add , After:=Sheets("ANA SAYFA")
ActiveSheet.Name = "Liste"
For X = 2 To Sheets.Count
Sheets("Liste").Cells(X - 1, 1) = Sheets(X).Name
If Sheets(X).Visible = False Then
Sheets(X).Visible = True
Sheets("Liste").Cells(X - 1, 2) = "Gizli"
End If
Next
[A:B].Sort Key1:=Range("A2"), Order1:=xlAscending
[A1].Select
For Y = 2 To Sheets.Count
Sheets("" & Cells(Y - 1, 1)).Move Before:=Sheets(Y)
Sheets("Liste").Select
If Sheets("Liste").Cells(Y - 1, 2) = "Gizli" Then
Sheets("" & Cells(Y - 1, 1)).Visible = False
End If
Next
Application.DisplayAlerts = False
Sheets("Liste").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[code]
İyi çalışmalar DUAYEN...
Kolay gele
#7
