- Katılım
- 22 Haziran 2005
- Mesajlar
- 120
Aşağıdaki kod excel sayfaları ekleyip, alfabetik sıraya koyup, bu sayfalara köprü oluşturuyor,bu sayfalardan da MALZEMELİST adlı sayfaya geri dönüş linki ekliyor.. Fakat oluşturulan bu geri dönüş, MALZEMELİST sayfasındaki A1 hücresine olmuyor. İstediğim bu geri dönüşün A1 hücresine olması.(setfocus=A1)
Sub sirala()
Application.Goto Reference:="R2C1"
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Integer
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
CRLF = Chr(10)
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
rg.Clear
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8# Then
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
Else
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
End If
On Error GoTo 0
Next cSht
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Goto Reference:="R1C1"
For i = 2 To Worksheets.Count
Worksheets(i).Hyperlinks.Add Anchor:=Worksheets(i).Cells(1, 1), Address:="", SubAddress:= _
"MALZEMELİST!A" & i, TextToDisplay:=" MALZEME LİSTESİ SAYFASINA GERİ DÃ?N"
For a = 1 To Sheets.Count
For b = a + 1 To Sheets.Count
If LCase(Sheets(b).Name) > LCase(Sheets(a).Name) Then GoTo 10
Sheets(b).Move before:=Sheets(a)
10 Next
Next
Next i
End Sub
Sub sirala()
Application.Goto Reference:="R2C1"
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Integer
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
CRLF = Chr(10)
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
rg.Clear
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8# Then
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
Else
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
End If
On Error GoTo 0
Next cSht
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Goto Reference:="R1C1"
For i = 2 To Worksheets.Count
Worksheets(i).Hyperlinks.Add Anchor:=Worksheets(i).Cells(1, 1), Address:="", SubAddress:= _
"MALZEMELİST!A" & i, TextToDisplay:=" MALZEME LİSTESİ SAYFASINA GERİ DÃ?N"
For a = 1 To Sheets.Count
For b = a + 1 To Sheets.Count
If LCase(Sheets(b).Name) > LCase(Sheets(a).Name) Then GoTo 10
Sheets(b).Move before:=Sheets(a)
10 Next
Next
Next i
End Sub