Makro, které Vám zvýrazní sloupec a řádek podle aktuální buňky.
Pokud si toto makro překopírujete do kořenového modulu listu a potom kliknete na nějakou buňku v listu, zvýrazní se Vám žlutě sloupec a řádek aktuální buňky. POZOR! Pokud máte v listu něco barevně zvýrazněno, tak se to tímto makrem vymaže a bude všechno bílé a jenom sloupec a řádek budou žluté. Je
to výhodné pro Ty, kteří mají v listu hodně řádků a sloupců.
Jak si ho překopírovat? A kam?
Otevřete si Visual Basic a v levém okně klikněte na název listu, ve kterém chcete makro používat. Zkopírujte makro do tohoto modulu. Zavřete Visual Basic. Pokud kliknete na jakoukoliv buňku v listu, zvýrazní se Vám kříž s buňkou uprostřed.
Pokud chcete zvýraznit pouze řádek, vymažte v makru řádek > .EntireColumn.Interior.ColorIndex = 19
Pokud chcete zvýraznit pouze sloupec, vymažte v makru řádek> .EntireRow.Interior.ColorIndex = 19
Barvu zvýraznění můžete měnit pomocí změny čísla za ColorIndex= od 1 do 56.
'
Začátek makra
Private Sub
Worksheet_SelectionChange(ByVal Target As Excel.Range)
Cells.Interior.ColorIndex = xlNone
With ActiveCell
.EntireRow.Interior.ColorIndex = 19
.EntireColumn.Interior.ColorIndex = 19
End With
End Sub
' Konec makra
Řěšíte problém, jak změnit linky v buňkách ze souboru "soubor.xls" do souboru "jinysoubor.xls"?
Toto makro je řešení. >> Najde název původního souboru v zadání linek v buňce a změní ho na název Vámi zadaného souboru. To provede ve všech nalezených buňkách a zároveň listech souboru. Tím se všechny linky přesměrují.
Po překopírování do modulu by mělo být makro stejně barevné jako zde.
'
Začátek makra
Sub
zmenasouboru()
'
Dim nazevlistu
Dim puvodnisoubor
Dim novysoubor
Dim i
nazevlistu = ActiveSheet.Name
Sheets(nazevlistu).Activate
Range("A1").Select
For i = 1 To Sheets.Count - 1
On Error GoTo pokracovat
ActiveSheet.Previous.Select
Next i
pokracovat:
puvodnisoubor = InputBox("Zadejte název souboru, který chcete změnit!", _
" Změnit název souboru! ", "Název souboru")
novysoubor = InputBox("Napište, prosím, nový název souboru!", _
" Nový název! ", "Nalinkovat kam?")
For i = 1 To Sheets.Count - 1
Cells.Replace What:=puvodnisoubor, Replacement:=novysoubor, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
ActiveSheet.Next.Select
Range("A1").Select
Next i
Sheets(nazevlistu).Activate
Range("A1").Select
End Sub
' Konec makra
Toto makro otevře nový soubor, napíše to, co si sami zadáte, do nápisu vytvořeného z hvězdiček
a po pěti vteřinách tento nápis a také tento soubor bez uložení zase zavře.
'
Začátek makra
Sub Napiscochces()
Const pi = 3.1416
Dim i As Integer
Dim x As Single, y As Single
Dim z As Single
Dim n As Single ' Délka nápisu v palcích
Dim k As Integer ' Počet hvězd
Dim sSize As Single ' Velikost hvězd
Dim sh As Shape
Dim sName As String ' Nápis
Dim StartLeft As Integer
Dim StartTop As Integer
' Otevřít nový sešit
Workbooks.Add
' Pozice začátku nápisu
StartLeft = ActiveCell.Left
StartTop = ActiveCell.Top
sName = InputBox("Co chceš mít napsáno?", "Nápis", "Tvé jméno?")
n = 5
k = Len(sName)
sSize = Application.InchesToPoints(0.5)
Randomize Timer
z = 0#
' Vytvořit první smyčku
For i = 1 To k
If Mid(sName, i, 1) <> " " Then
x = n * i / k
x = Application.InchesToPoints(x)
' Náhodně zadat 0 nebo 1. Nápis stoupá nebo klesá.
If Int(2 * Rnd) = 0 Then
z = z + 0.2
Else
z = z - 0.2
End If
y = Application.InchesToPoints(z)
Set sh = ActiveSheet.Shapes.AddShape _
(msoShape5pointStar, StartLeft + x, StartTop + y, sSize, sSize)
' Doplnit stín
sh.Fill.ForeColor.RGB = RGB(230, 230, 230)
sh.Fill.Visible = msoTrue
' Doplnit text
sh.TextFrame.Characters.Text = Mid(sName, i, 1)
sh.TextFrame.Characters.Font.Size = 10
sh.TextFrame.Characters.Font.Name = "Arial"
sh.TextFrame.Characters.Font.Bold = True
sh.TextFrame.Characters.Font.ColorIndex = 3
End If
Next i
'Čekat 5 vteřin
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 5
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
'Smazat hvězdy
ActiveSheet.Shapes.SelectAll
Selection.Delete
'Zavřít sešit bez uložení
ActiveWorkbook.Close savechanges:=False
End Sub
' Konec makra
Zpět na hlavní stránku