MS Excel - otázky a opovědi

hlavní stránka > MS Excel - otázky a odpovědi

MS EXCEL - otázky a odpovědi

Pokud potřebujete poradit, zašlete nám svůj dotaz... faq@dataspectrum.cz.

18.08.2003 |

Jakým způsobem mohu zapsat pomocí VBA vzorec pro výpočet součtu buněk sloupce - ekvivalent k zápisu SUMA(A1:A10)?

Pomocí následujícího kódu vložíte součtový vzorec za poslední vyplněnou buňku ve sloupci A.

Sub SoucetSloupce()
'zapise vzorec pro soucet pod posledni vyplnenou bunku ve sloupci "A"
Dim bunka As Range
    Set bunka = Cells(Rows.Count, "A")
    Set bunka = bunka.End(xlUp)
    Set bunka = bunka(2)
    bunka.FormulaR1C1 = "=SUM(R1C:R[-1]C)"
End Sub

3.08.2003 |

Je možné pomocí VBA kódu umístit na list Excelu ovládací prvek - například zaškrtávací políčko?

Následující kód vloží do buňky C3 aktivního listu zaškrtávací políčko s vazbou na buňku A3. Zároveň je nastaveno i zabarvení oblasti políčka a je přiřazeno makro "SpustitTotoMakro".

Sub AddCheckBox()

    Dim intCellTop As Integer
    Dim intCellLeft As Integer
    Dim intBoxHeight As Integer
    Dim intBoxWidth As Integer

    'kde mam umistit policko
    intCellTop = Cells(3, 3).Top
    intCellLeft = Cells(3, 3).Left
    'vyska a sirka policka
    intBoxHeight = 15
    intBoxWidth = 75

    With ActiveSheet.CheckBoxes.Add(intCellLeft, _
                        intCellTop, intBoxWidth, intBoxHeight)
            'zobrazeny text
            .Characters.Text = "Moje policko"
            'xlOn = oznaceno, xlOff = neoznaceno
            .Value = xlOn
            .Value = xlOff
            
            'adresa provazane bunky
            .LinkedCell = "$A$3"
            .OnAction = "SpustitTotoMakro"

            'add fill colour
            .ShapeRange.Fill.ForeColor.SchemeColor = 12
            .ShapeRange.Fill.Solid
            .ShapeRange.Fill.Visible = msoTrue

            'ohraniceni/barva cary
            .ShapeRange.Line.ForeColor.SchemeColor = 13
            .ShapeRange.Line.Visible = msoTrue
    End With

End Sub

1.08.2003 |

Potřebuji napsat kód, který by upozornil na sloupec, který je příliš úzký pro hodnoty uložené v jeho buňkách - zobrazuje se ######.

Sub FindIncorrectDataDisplay()
  Dim rng As Range
  For Each rng In ActiveSheet.UsedRange
    If IsNumeric(rng.Value) And Left(rng.Text, 1) = "#" Then
      MsgBox "Sloupec je příliš úzký pro hodnotu v buňce: " & rng.Address
    End If
  Next rng
End Sub

15.04.2003 |

Jakým způsobem je možné v Excelu přehrát zvukové soubory?

V následujícím textu naleznete 3 postupy, jak využít k přehrání zvukových souborů API funkce Windows:

příklad č.1

'PREHRAVA SOUBORY Wav, AVI, MID
'POUZIJ SUB TESTIT()
'***************************************'
Public Const pcsSYNC = 0      ' CEKEJ NA UKONCENI PREHRAVANI
Public Const pcsASYNC = 1     ' NECEKEJ NA UKONCENI PREHRAVANI
Public Const pcsNODEFAULT = 2 ' POKUD NENELEZNES SOUBOR, PAK NEPREHRAVEJ PREDNASTAVENY ZVUK
Public Const pcsLOOP = 8      ' PREHRAVEJ V NEKONECNE SMYCCE (DOKUD NENI ZNOVU POUZIT apiPlaySound)
Public Const pcsNOSTOP = 16   ' NEPRERUSUJ PREHRAVANY SOUBOR

'Sound APIs
Private Declare Function apiPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

'AVI APIs
Private Declare Function apimciSendString Lib "winmm.dll" Alias "mciSendStringA" _
    (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
    ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Declare Function apimciGetErrorString Lib "winmm.dll" _
    Alias "mciGetErrorStringA" (ByVal dwError As Long, _
    ByVal lpstrBuffer As String, ByVal uLength As Long) As Long


Function fPlayStuff(ByVal strFilename As String, _
            Optional intPlayMode As Integer) As Long

Dim lngRet As Long
Dim strTemp As String

    Select Case LCase(fGetFileExt(strFilename))
        Case "wav":
            If Not IsMissing(intPlayMode) Then
                lngRet = apiPlaySound(strFilename, intPlayMode)
            Else
                MsgBox "Must specify play mode."
                Exit Function
            End If
        Case "avi", "mid":
            strTemp = String$(256, 0)
            lngRet = apimciSendString("play " & strFilename, strTemp, 255, 0)
    End Select
    fPlayStuff = lngRet
End Function
Function fStopStuff(ByVal strFilename As String)
'ZASTAV PREHRAVANI
Dim lngRet As Long
Dim strTemp As String
    Select Case LCase(fGetFileExt(strFilename))
        Case "Wav":
            lngRet = apiPlaySound(0, pcsASYNC)
        Case "avi", "mid":
            strTemp = String$(256, 0)
            lngRet = apimciSendString("stop " & strFilename, strTemp, 255, 0)
    End Select
    fStopStuff = lngRet
End Function

Private Function fGetFileExt(ByVal strFullPath As String) As String
Dim intPos As Integer, intLen As Integer
    intLen = Len(strFullPath)
    If intLen Then
        For intPos = intLen To 1 Step -1
            'NALEZNI POSLEDNI ZNAK \
            If Mid$(strFullPath, intPos, 1) = "." Then
                fGetFileExt = Mid$(strFullPath, intPos + 1)
                Exit Function
            End If
        Next intPos
    End If
End Function

Function fGetError(ByVal lngErrNum As Long) As String
    ' PREVED KOD CHYBY NA RETEZEC
    Dim lngx As Long
    Dim strErr As String

    strErr = String$(256, 0)
    lngx = apimciGetErrorString(lngErrNum, strErr, 255)
    strErr = Left$(strErr, Len(strErr) - 1)
    fGetError = strErr
End Function
Sub TestIt()
'ZADEJ AKTUALNI CESTU K PREHRAVANEMU SOUBORU
Dim a As Long
    a = fPlayStuff("C:\zalohy\eee\01.avi")
'    a = fStopStuff("C:\zalohy\eee\01.avi")
'    a = fPlayStuff("C:\harp.wav")
'    a = fStopStuff("C:\harp.wav")

End Sub

příklad č.2

Private Declare Function midiOutClose Lib "winmm.dll" _
                 (ByVal hMidiOut As Long) As Long

 Private Declare Function midiOutOpen Lib "winmm.dll" _
                 (lphMidiOut As Long, _
                 ByVal uDeviceID As Long, _
                 ByVal dwCallback As Long, _
                 ByVal dwInstance As Long, _
                 ByVal dwFlags As Long) As Long
 Private Declare Function midiOutShortMsg Lib "winmm.dll" _
                 (ByVal hMidiOut As Long, _
                 ByVal dwMsg As Long) As Long
 Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
 Dim hMidiOut As Long
 Public lanote As Integer
 Public Const durée As Integer = 250 ' milisekundy'

 Sub PlayMIDI()
 Numéro = 0
 notes_a_jouer = Array(50, 50, 52, 50, 55, 54, 50, _
 50, 52, 50, 57, 55, 50, 50, _
 62, 59, 55, 54, 52, 60, 60, 59, 55, 57, 55)
    For Each noteG In notes_a_jouer
     Numéro = Numéro + 1
     dur_n = Array(400, 250, 700, 600, 650, 800, 400, _
     250, 700, 600, 650, 800, 600, 400, 800, _
     600, 600, 800, 600, 400, 300, 600, 600, 600, 2000)
     Temps = dur_n(Numéro - 1)
     On Error Resume Next
     midiOutClose hMidiOut '------ZAVRI PORT MIDI PRO PREDCHOZI TON
     midiOutOpen hMidiOut, 0, 0, 0, 0  ' ------OTEVRI PORT MIDI PRO NOVY TON
     midiOutShortMsg hMidiOut, RGB(192, 84 - 1, 127)
     lanote = 12 + CInt(noteG)  ' -----SPOCITEJ OKTAVU
     note = RGB(144, lanote, 127)
     midiOutShortMsg hMidiOut, note ' ----PREHRAJ NOTU NA PORTU MIDI
     Sleep (Temps)
     midiOutClose hMidiOut
   Next
 End Sub

příklad č.3

'ZAZNAM A PREHRATI ZVUKU VE FORMATU WAV
'**********************************************************
' MCI funkce lze pouzit pro zaznam souboru ve formatu WAV
' zakladem funkce MCI je mciSendString,  ktera predava
' prikazy ve forme retezce systemovemu zarizeni MCI a vykonava je
' Zarizeni, ktere ma bzt pouzito je specifikovano v retezci
' V tomto pripade se jedna o waveaudio

Private Declare Function mciSendString Lib "winmm" _
   Alias "mciSendStringA" ( _
   ByVal lpstrCommand As String, _
   ByVal lpstrReturnString As String, _
   ByVal uReturnLength As Long, _
   ByVal hwndCallback As Long) As Long

Private Declare Function mciExecute Lib "winmm" ( _
   ByVal lpstrCommand As String) As Long

Private Declare Function sndPlaySound Lib "winmm.dll" _
   Alias "sndPlaySoundA" ( _
   ByVal lpszSoundName As String, _
   ByVal uFlags As Long) As Long
    
Private Const SND_SYNC = &H0
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
Private Const SND_LOOP = &H8
Private Const SND_NOSTOP = &H10


Private Const strAlias As String = "RcrdWavFile "
Private Const strOpenCmd As String = "Open new type waveaudio alias " & strAlias
Private Const strRecordCmd As String = "Record " & strAlias
Private Const strTimeCmd As String = "Record " & strAlias & " to "
Private Const strWaitCmd As String = " WAIT"
Private Const strSaveCmd As String = "Save " & strAlias
Private Const strCloseCmd As String = "Close " & strAlias
'soubor, do ktereho ma byt zvuk zaznamenan
Private Const strSaveAs As String = "C:\harp.wav"

Sub TestRecording()
Dim strCommand As String
Dim ExecCmd As Long
Dim tWait

tWait = 5

'otevri zaznamove zarizeni
ExecCmd = mciSendString(strOpenCmd, vbNullString, 0, 0&)
'zacni zaznamenavat
ExecCmd = mciSendString(strRecordCmd, vbNullString, 0, 0&)
'nastav dobu trvani zaznamu
ExecCmd = mciSendString(strTimeCmd & (tWait * 1000) & strWaitCmd, _
   vbNullString, 0, 0&)
'uloz zaznamenany zvuk
ExecCmd = mciSendString(strSaveCmd & strSaveAs, vbNullString, 0, 0&)
'zavri zarizeni
ExecCmd = mciSendString(strCloseCmd, vbNullString, 0, 0&)

'info pro uzivatele o skonceni zaznamu
MsgBox "Záznam ukonèen", vbInformation

End Sub

Sub PlayBack()
   WAVPlay strSaveAs
End Sub

Sub PlayBackLoop()
   WAVLoop strSaveAs
End Sub

Sub PlayBackStop()
'pokud je prehravano v nekonecne smycce, pak zastav
    Call WAVPlay(vbNullString)
End Sub


Sub WAVLoop(File As String)
    Dim SoundName As String
    Dim wFlags As Long
    Dim x As Long
    
    SoundName = File
    wFlags = SND_ASYNC Or SND_LOOP
    x = sndPlaySound(SoundName, wFlags)
    If x = 0 Then MsgBox "Nemohu otevrit soubor. " & File

End Sub

Sub WAVPlay(File As String)
    Dim SoundName As String
    Dim wFlags As Long
    Dim x As Long
    
    SoundName = File
    wFlags = SND_ASYNC Or SND_NODEFAULT
    x = sndPlaySound(SoundName, wFlags)
    If x = 0 Then MsgBox "Nemohu otevrit soubor " & File

End Sub

24.03.2003 |

Je možné pomocí VBA vytvořit v aktivním listu čáru, která by začínala v horním levém rohu obrazovky a končila v dolním pravém rohu? Chtěl bych tímto způsobem indikovat, že se jedná o vzorová data nebo výpočet.

Následující kód vytvoří čáru přesně podle poždavku.

Sub Diagonal()
'nakreslí diagonálu na oblast stránky, která je viditelná v okně
Dim TopLeftCell As Range
Dim NumR As Long
Dim NumC As Long

NumR = ActiveWindow.ScrollRow
NumC = ActiveWindow.ScrollColumn

Set TopLeftCell = ActiveSheet.Cells(ActiveWindow.ScrollRow, ActiveWindow.ScrollColumn)
ActiveSheet.Shapes.AddLine(TopLeftCell.Left, TopLeftCell.Top, _
         TopLeftCell.Left + ActiveWindow.UsableWidth - 18, _
         TopLeftCell.Top + ActiveWindow.UsableHeight - 13).Select
End Sub

12.03.2003 |

Lze pomocí VBA indikovat rozdíly v hodnotách sloupců? Mám list s daty ve sloupci A a B ( identifikační názvy poboček naší společnosti na konci roku 2001 a 2002), které se v některých případech liší. Potřebuji vyznačit tyto rozdíly.

A	B
aaa	aaa
bbb	bbb
ccc	eee	<== vyznačit rozdíl
ggg	kkk	<== vyznačit rozdíl
jjj	jjj

Následující kód vyznačí rozdíly mezi daty sloupců ve vybrané oblasti. Aktivujte oblast A1:B5 a spusťte kód - odlišná hodnota bude zapsána tučným červeným písmem. Záleží na způsobu výběru - zkuste vybírat od buňky A1 k B5, spustit kód a potom od B1 k A5.

Sub RowDifferences()
 On Error Resume Next
 With Selection.RowDifferences(ActiveCell)
    .Font.ColorIndex = 3
    .Font.Bold = True
 End With
End Sub

21.02.2003 |

Existuje nějaký jednoduchý způsob, jak v ExceluXP odeslat z listu email?

Vložte do buňky listu hypertextový odkaz - například pomocí CTRL+K a do adresy vložte text

  xx@yy.cz?subject=pokusný text&body=Tento text vložil Excel

Část textu uvozená pomocí subject= bude vložena do předmětu zprávy a text uvozený pomocí body= je vložený do těla zprávy. Výhodou tohoto řešení je, že pracuje nejenom s poštovním klientem Outlook, ale i s ostatními produkty.

16.02.2003 |

Potřeboval bych do všech buněk vybrané oblasti přidat funkci ZAOKROUHLIT. V některých buňkách jsou uloženy pouze hodnoty , v některých ale i vzorce.

Problém lze vyřešit na základě následujícího kódu:

Sub AddRoundToFormula()
Dim cll As Range
For Each cll In Selection
   'buňka obsahuje numerickou hodnotu
   If IsNumeric(cll.Value) = True And cll.Value <> "" Then
    If Mid(cll.Formula, 2, 5) <> "ROUND" Then
     'buňka NEobsahuje funkci ZAOKROUHLIT
      If cll.Formula = CStr(cll.Value) Then
       'buňka NEobsahuje funkci
        cll.Formula = "=ROUND(" & cll.Formula & ",0)"
        Else
         'buňka obsahuje funkci
        cll.Formula = "=ROUND(" & Mid(cll.Formula, 2) & ",0)"
      End If
     End If
   End If
   Next cll
End Sub

3.02.2003 |

Lze ovládat CD drive pomocí kódu?

Ano, pokud využijete volání příslušné API funkce

Declare Sub mciSendStringA Lib "winmm.dll" (ByVal lpstrCommand As String, _
ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, _
ByVal hwndCallback As Long)

Sub OpenCDTray()
  mciSendStringA "Set CDAudio Door Open", 0&, 0, 0
End Sub

Sub CloseCDTray()
  mciSendStringA "Set CDAudio Door Closed", 0&, 0, 0
End Sub

30.01.2003 |

Je možné vybrat ze skupiny dat pouze unikátní hodnoty?

Úlohu lze vyřešit více způsoby. Dobrým programátorským návykem však je používat v maximální míře vestavěné algoritmy Excelu. Ty jsou totiž odladěny a kompilovány v prostředí jazyka C+ a jsou tedy rámcově 10x rychlejší než příslušné postupy založené na VBA.
V našem případě využijeme objekt AdvancedFilter představující pokročilý filtr přístupný pomocí nabídky "Data" v uživatelské obrazovce Excelu, který umožňuje selekci unikátních hodnot v oblasti dat.

Sub FindUniqueValues(SourceRange As Range, TargetCell As Range)
'SourceRange - oblast dat, ve které hledáme unikátní hodnoty
'TargetCell - první buňka (levý horní roh) oblasti, do které kód zapíše nalezené unikátní hodnoty
  SourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=TargetCell, Unique:=True
End Sub

29.01.2003 |

Lze pomocí VBA zjistit rozlišení monitoru?

Obecně to možné není. Nicméně můžete použít volání příslušné API funkce. Potřebný kód je přiložen

Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Const SM_CYSCREEN As Long = 1
Const SM_CXSCREEN As Long = 0

Sub GetScreenDimensions()
  Dim lWidth As Long
  Dim lHeight As Long
  lWidth = GetSystemMetrics(SM_CXSCREEN)
  lHeight = GetSystemMetrics(SM_CYSCREEN)
  MsgBox "Horizontální rozlišení = " & lWidth & vbCrLf & "Vertikální rozlišení = " & lHeight
End Sub

27.01.2003 |

Lze zabránit uživateli uzavřít formulář stiskem tlačítka "X" v pravém horním rohu?

Následující kód upozorní uživatele, že stisk tlačítka není povolen a nedovolí formulář uzavřít.

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
   MsgBox "Tato akce není povolena!"
   'následující řádek zabraňuje uzavření formuláře
   Cancel = True
End If
End Sub