Skip to main content

AccessTr.neT


Hücrelerdeki isimlere göre sayfa oluşturma

Hücrelerdeki isimlere göre sayfa oluşturma

Çözüldü #9
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...
Bizim için zor diye bir şey yoktur, imkansızsa zaman alır...
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da

Bu Konudaki Yorumlar
Cvp: Hücrelerdeki isimlere göre sayfa oluşturma - Yazar: DUAYEN - 10/04/2012, 15:36
Task