collect sheet name:
Sub ListSheets()
Dim ws As Worksheet
Dim x As Integer
x = 1
Sheets("Sheet1").Range("A:A").Clear
For Each ws In Worksheets
Sheets("Sheet1").Cells(x, 1) = ws.Name
x = x + 1
Next ws
End Sub
...................................................................................
..
insert workshhet according to list:(by range):
Sub AddSheets()
'Updateby Extendoffice 20161215
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A1:A7")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
by selection:
-----------------
Sub AddWorksheetsFromSelection()
Dim CurSheet As Worksheet
Dim Source As Range
Dim c As Range
Set CurSheet = ActiveSheet
Set Source = Selection.Cells
Application.ScreenUpdating = False
For Each c In Source
sName = Trim(c.Text)
If Len(sName) > 0 Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sName
End If
Next c
CurSheet.Activate
Application.ScreenUpdating = True
End Sub
-----------------------------------------------------------------------------------
------------------------------
hyprlink sheets:
Sub CreateIndex()
'updateby Extendoffice 20150914
Dim xAlerts As Boolean
Dim I As Long
Dim xShtIndex As Worksheet
Dim xSht As Variant
xAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Index").Delete
On Error GoTo 0
Set xShtIndex = Sheets.Add(Sheets(1))
xShtIndex.Name = "Index"
I = 1
Cells(1, 1).Value = "INDEX"
For Each xSht In ThisWorkbook.Sheets
If xSht.Name <> "Index" Then
I = I + 1
xShtIndex.Hyperlinks.Add Cells(I, 1), "", "'" & xSht.Name & "'!A1", ,
xSht.Name
End If
Next
Application.DisplayAlerts = xAlerts
End Sub
Sub ListSheets()
Dim ws As Worksheet
Dim x As Integer
x = 1
Sheets("Sheet1").Range("A:A").Clear
For Each ws In Worksheets
Sheets("Sheet1").Cells(x, 1).Select
ActiveSheet.Hyperlinks.Add _
Anchor:=Selection, Address:="", SubAddress:= _
ws.Name & "!A1", TextToDisplay:=ws.Name
x = x + 1
Next ws
End Sub
-----------------------------------------------------------------------------------
---------------------------------
back to first sheet
-------------------
Sub CreateLinksOnAllSheets()
Dim sh As Worksheet
Dim cell As Range, i As Integer
With ActiveWorkbook
For i = 1 To ActiveWorkbook.Worksheets.Count
If ActiveSheet.Name <> .Worksheets(i).Name Then
.Worksheets(i).Hyperlinks.Add Anchor:= _
.Worksheets(i).Range("A1"), Address:="", SubAddress:= _
"'" & ActiveSheet.Name & "'" & "!A1", TextToDisplay:="Back"
End If
Next i
End With
End Sub
---------------------------------------------------------------------
Copying Data that Meets Criteria:
Sub Test()
Dim i As Integer
Application.ScreenUpdating=False
For i=2 To 101
If Range("B" & i).Value="Ford" Then
Range("B" & i).EntireRow.Copy
Sheets("Sheet2").Select
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Sheet1").Select
End If
Next i
Application.ScreenUpdating=True
End Sub
-----------------------------------------------------------------------------------
----------------
Option Explicit
Sub Filter1() 'Excel VBA to use the autofilter then copy
Range("A1:A101").AutoFilter 1, "Ford"
Range("A1:A101").Copy Sheet2.Range("A" & Rows.Count).End(xlUp)(2)
Range("A1").Autofilter 'Off with the autofiltter
End Sub
-----------------------------------------------------------------------------------
-----------
inser n rows
Sub InsertRows()
Application.ScreenUpdating = False
Dim numRows As Integer
Dim r As Long
r = Cells(Rows.Count, "A").End(xlUp).Row
numRows = 1
For r = r To 1 Step -1
ActiveSheet.Rows(r + 1).Resize(numRows).Insert
Next r
Application.ScreenUpdating = True
End Sub
-----------------------------------------------------------------------------------
---------------------
Sub RenameSheets()
Dim c As Range
Dim J As Integer
J = 0
For Each c In Range("A1:A12")
J = J + 1
If Sheets(J).Name = "Control" Then J = J + 1
Sheets(J).Name = c.Text
Next c
End Sub
