Scribd
Upload
193 views

Micro Code

This document contains VBA code snippets for common Excel worksheet and sheet tasks including: 1. Listing all worksheets in a workbook in a range on Sheet1. 2. Adding new worksheets from a range of names on Sheet1. 3. Creating hyperlinks on an "Index" sheet to navigate between other sheets. 4. Adding hyperlinks to each sheet's A1 cell to return to the first sheet.

Uploaded by

kaka
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
193 views

Micro Code

This document contains VBA code snippets for common Excel worksheet and sheet tasks including: 1. Listing all worksheets in a workbook in a range on Sheet1. 2. Adding new worksheets from a range of names on Sheet1. 3. Creating hyperlinks on an "Index" sheet to navigate between other sheets. 4. Adding hyperlinks to each sheet's A1 cell to return to the first sheet.

Uploaded by

kaka
Copyright
© © All Rights Reserved
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 4

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

You might also like