AccessTr.neT
Hücrelerdeki isimlere göre sayfa oluşturma - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Hücrelerdeki isimlere göre sayfa oluşturma (/konu-hucrelerdeki-isimlere-gore-sayfa-olusturma.html)

Sayfalar: 1 2


Cvp: Hücrelerdeki isimlere göre sayfa oluşturma - drummers - 09/04/2012


Ne demekImg-grin Kolay gele
[/quote]
Ne demek şimdi bu ?
[/quote]

Şuan nöbetciyim fazla ilgilenemiyorum kusura bakmayın yazmışsınız

Bende kusur ne demek, canınız sağ olsun, anlamında kolay gele demek istedim...


Cvp: Hücrelerdeki isimlere göre sayfa oluşturma - DUAYEN - 09/04/2012

Özür dilerim ben yanlış anlamışım.


Cvp: Hücrelerdeki isimlere göre sayfa oluşturma - DUAYEN - 10/04/2012

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...


Cvp: Hücrelerdeki isimlere göre sayfa oluşturma - drummers - 10/04/2012

(10/04/2012, 15:36)DUAYEN yazdı: 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...

Teşekkürler...