Tabele przestawne nie mają (poza odświeżaniem przy otwarciu zeszytu) opcji automatycznego odswieżania wraz ze zmianą danych źródłowych.
Pewnym rozwiązaniem może być zastosowanie kodu VBA zdarzenie uaktywnienia arkusza.
Kod oczywiście umieszczamy w module arkusza w którym znajduje się tabela.
Private Sub Worksheet_Activate()
Dim mysheet As Worksheet
'definiujemy w którym arkuszu sa dane źródłowe
Set mysheet = Sheets("Dane")
Application.ScreenUpdating = False
'przypisujemy adres zakresu w jakim są dane źródłowe
'(przy założeniu, że komórka A1 znajduje się w zakresie danych źródłowych)
myrange = mysheet.Name & "!" & _
mysheet.Range("A1").CurrentRegion.Address(ReferenceStyle:=xlR1C1)
'przypisujemy zakres danych źródłowych tabeli przestawnej
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:=myrange
'odświeżamy tabelę przestawną
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
'ukrywamy paski narzędzi związanych z tabelą przestawną
ActiveWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False
Application.ScreenUpdating = True
End Sub
Generalnie wykonanie makra nie umożliwia jego cofnięcia - nie można skorzystać z przycisku 'cofnij'.
Jednakże, odpowiednie napisanie kodu może nam umożliwić cofanie makra.
Poniższy kod jest tylko przykładem z założenia możliwie najprostszym - cofamy tutaj makro zmieniające format liczbowy aktywnej komórki. Działanie na zakresach wielokomórkowych będzie wymagało skorzystania z tablic.
Private oldformat As String
Sub Format()
'zapamiętuje jaki był poprzedni format liczbowy
oldformat = ActiveCell.NumberFormat
'zamienia format liczbowy
ActiveCell.NumberFormat = "#,##0.00"
'przysuje metodzie undo makro przywracające stary format
Application.OnUndo "Cofnij formatowanie", "UndoFormat"
End Sub
Sub UndoFormat()
'wstawia stary format liczbowy
ActiveCell.NumberFormat = oldformat
End Sub
Rozwinięcie tematu z artykułu wykresnauserformie.htm.
Otóż problem był następujący: czy da się jakimś magicznym sposobem wstawić do UserForma kopię dowolnego zakresu z arkusz?
Odpowiedź jest twierdząca, a zostałą wyszperana na grupie microsoft.public.excel.programming, autor postu rondebruin (at) kabelfoon.nl.
Oto ona:
Sub make_gif_file()
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set ctoTheChartHolder = ActiveSheet.ChartObjects.Add(0, 0, 800, 600)
Set chtTheChart = ctoTheChartHolder.Chart
' Paste the picture onto the chart and
' set an object variable for it
ctoTheChartHolder.Activate
With chtTheChart
.ChartArea.Select
.Paste
Set picThePicture = .Pictures(1)
End With
' Set the picture's properties...
With picThePicture
.Left = 0
.Top = 0
sglWidth = .Width + 7
sglHeight = .Height + 7
End With
' Change the size of the chart object to fit the picture
'better
With ctoTheChartHolder
.Border.LineStyle = xlNone
.Width = sglWidth
.Height = sglHeight
End With
' Which filter to use?..
strFileExtension = "bmp"
' Export the chart as a graphics file
blnRet = chtTheChart.Export(Filename:="c:\range.gif", _
Filtername:="gif", Interactive:=False)
ctoTheChartHolder.Delete
End Sub
Jeżeli potrzebujemy wydrukować dokumnet na inną niż domyśłna drukarkę możemy posłużyć się następującym kodem (źródło: http://www.erlandsendata.no):
Sub PrintToAnotherPrinter()
Dim STDprinter As String
STDprinter = Application.ActivePrinter
'tymczasowa zmiana drukarki
Application.ActivePrinter = "microsoft fax na fax:" 'nazwa drukarki
'na którą chcemy wydrukowć dokument
ActiveSheet.PrintOut
'powrót do poprzedniej drukarki
Application.ActivePrinter = STDprinter
End Sub
Dział sprzedaży w firmie dostarczającej usługi ciągłe (usługi oczyszczania) przygotowuje miesięczne zestawienie sprzedaży ad hoc, na podstawie którego dział księgowości przygotowuje faktury. Zestawienie ma następujący format:
Zdarzają się miesiące kiedy dział księgowości musi takich faktur przygotować kilkadziesiąt co jednej osobie zajmuje cały dzień pracy.
Lekarstwem okazało się wdrożenie makr VBA, które eksportują zapisy z powyższego zestawienia do pliku tekstowego, który następnie może zostać zaimportowany do programu księgowego. Procedura ta eliminuje konieczność ręcznego wprowadzania faktur, dzięki czemu obecnie wystawienie faktur trwa mniej niż pół godziny.
Dział sprzedaży wstawia w kolumnie 'I' znak, że daną sprzedaż można już zafakturować, Dział księgowości weryfikuje dane zawarte w zestawieniu z posiadaną dokumentacją i w kolumnie 'J' wstawia znak oznaczający, że dany rekord może zostać wyeksportowany. Makro sprawdza czy w kolumnie 'J' znajduje się litera 'T' lub słowo 'tak' i eksportuje dany rekord, a następnie usuwa znak/znaki z kolumny 'J' w celu uniknięcia pomyłkowego dwukrotnego zafakturowania tej samej sprzedaży.
Sprzedaż jest księgowana analitycznie wg rodzaju i sprzedawcy, ponieważ kody używane w programie księgowym i zestawieniu nie odpowiadają sobie, konieczne było utworzenie w dodatkowym arkuszu odpowiednich słowników:
Makro eksportujące faktury do pliku tekstowego wygląda następująco:
Public komorka As Range
Public zapisztekst As String
Sub eksportFaktur()
Dim eksportrange As Range
Dim licz As Long
'definiuje zakres w którym są 'T'
Sheets("sprzedaż").Select
kolumna = Range("eksport").Column
Set eksportrange = Range(Cells(1, kolumna), Cells(5000, kolumna))
'otwiera plik txt
sciezka = Range("sciez").Text
nazwa = "faktury.txt"
Open sciezka & "\" & nazwa For Output As #1
'zapisuje faktury do pliku txt
licz = 0
For Each komorka In eksportrange
If komorka.Text = "T" Or komorka.Text = "t" Or komorka.Text = "TAK" _
Or komorka.Text = "tak" Then
'tutaj kod eksportu
Call eksportuj_linie_zam
komorka.Value = ""
Print #1, zapisztekst
licz = licz + 1
End If
Next
Close #1
'wyświetla informację o liczbie wyeksportowanych linii
info = MsgBox("You have succesfully exported " & licz & " order lines" & _
vbCr & "to " & sciezka & "\" & nazwa & ".", vbInformation)
End Sub
Sub eksportuj_linie_zam()
'definiuje w ktorych kolumnach sa skladowe exportu
wiersz = komorka.Row
invcustcodeKol = Range("code").Column
stockKol = Range("categ").Column
priceKol = Range("amount").Column
salesmanKol = Range("salesman").Column
'definiuje skladowe exportu
invcustcode = Cells(wiersz, invcustcodeKol).Value
orderdate = Format(Date, "yyyymmdd")
stockcode = Cells(wiersz, stockKol).Value
For Each znajdz In Range("KODY")
If znajdz.Value = stockcode Then
stockcode = znajdz.Offset(0, 1).Value
Exit For
End If
Next
orderqty = 1
salesman = Cells(wiersz, salesmanKol)
For Each znajdz In Range("OSOBY")
If znajdz.Value = salesman Then
employee = znajdz.Offset(0, 1).Text
Exit For
End If
Next
price = Cells(wiersz, priceKol).Value
'tworzy ciąg zapisywany do txt
zapisztekst = invcustcode & orderdate & stockcode & orderqty & _
employee & price
End Sub
W arkuszu muszą występować następujące nazwy:
eksport - w wierszu 1 kolumny, w którą wpisujemy T/tak
code - w wierszu 1 kolumny, w którą wpisujemy nr/symbol klienta
categ - w wierszu 1 kolumny, w którą wpisujemy rodzaj sprzedaży
kody - zakres, w którym znajduje się słownik kodów rodzaju sprzedaży
amount - w wierszu 1 kolumny, w którą wpisujemy kwotę faktury
osoby - zakres, w którym znajduje się słownik osób
salesman - w wierszu 1 kolumny, w którą wpisujemy sprzedawcę
Rezultat eksportu jest następujący:
Może, się zdarzyć tak, że będziemy potrzebowali filtrować nie wiersze (co nam umożliwia autofiltr czy też filtr zaawansowany), ale kolumny. Niestety brak jest takiego wbudowanego mechanizmu w excelu. Ale od czego VBA i pomysłowość? Oto makro nadesłane przez Henryka Tomczyka rozwiązujące ten problem (kod należy wstawić w arkusz, w którym chcemy mieć tę funkcjonalność):
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'Kliknij wiersz poszukiwań prawym klawiszem myszy
If Selection.Rows.Count <> 1 Or Selection.Cells.Count = 1 Then End
' Cancel = True
ciag = InputBox("Podaj szukany ciąg.")
If ciag = "" Then End
Application.ScreenUpdating = False
With Selection
Set c = .Find(ciag, LookIn:=xlValues)
If Not c Is Nothing Then
pierw_adr = c.Address
Columns.ColumnWidth = 0.05
Do
Range(c.Address).EntireColumn.AutoFit
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> pierw_adr
End If
End With
If c Is Nothing Then MsgBox "Ciąg >> " & ciag & " << nie występuje!"
Application.ScreenUpdating = True
End Sub
Bardzo prosta funkcja zwracająca kolor wypełnienia komórki w postaci indexu (numeru) koloru. Jedyny mankament funkcji zwracających formatowanie komórki to, że funkcja nie zostanie przeliczona w momencie zmiany formatu komórki - zmiana formatu nie jest zdarzeniem obsługiwanym przez VBA - przynajmniej nic mi o tym nie wiadomo - jeżeli ktoś ma pomysł jak to rozwiązać - proszę o info.
Function kolorkomorki(adres As Range)
kolorkomorki = adres.Interior.colorindex
End Function
Często się zdarza, że potrzebujemy wczytać dane z pliku tekstowego do arkusza. Poniższy przykład kodu importuje dane zawarte w pliku tekstowym (zlokalizowanym w tym samym folderze co arkusz) do aktywnego arkusza excela. Każda kolejna linia pliku tekstowego jest umieszczana w nowym wierszu arkusza:
Sub czytajtxt()
Open ThisWorkbook.Path & "/tekst.txt" For Input As #1
wiersz = 0
Do While Not EOF(1)
Line Input #1, data
ActiveCell.Offset(wiersz, 0) = data
wiersz = wiersz + 1
Loop
Close #1
End Sub
Poniższy kod (nie testowany przeze mnie) importuje dane z pliku tekstowego zawierającego więcej rekordów niż limit wynikający z liczby rekordów pojedynczego arkusza excela. Kolejne rekordy są importowane do kolejnych arkuszy excela.
Kod został opublikowany na grupie microsoft.public.excel.programming (dodałem tylko na końcu Application.ScreenUpdating = True).
Sub LargeFileImport()
'Dimension Variables
Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
'Ask User for File's Name
FileName = Application.GetOpenFilename
'Check for no entry
If FileName = "" Then End
'Get Next Available File Handle Number
FileNum = FreeFile()
'Open Text File For Input
Open FileName For Input As #FileNum
'Turn Screen Updating Off
Application.ScreenUpdating = False
'Create A New WorkBook With One Worksheet In It
Workbooks.Add Template:=xlWorksheet
'Set The Counter to 1
Counter = 1
'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)
'Display Importing Row Number On Status Bar
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName
'Store One Line Of Text From File To Variable
Line Input #FileNum, ResultStr
'Store Variable Data Into Active Cell
If Left(ResultStr, 1) = "=" Then
ActiveCell.Value = "'" & ResultStr
Else
ActiveCell.Value = ResultStr
End If
'For xl95 change 65536 to 16384
If ActiveCell.Row = 65536 Then
'If On The Last Row Then Add A New Sheet
ActiveWorkbook.Sheets.Add
Else
'If Not The Last Row Then Go One Cell Down
ActiveCell.Offset(1, 0).Select
End If
'Increment the Counter By 1
Counter = Counter + 1
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close
'Remove Message From Status Bar
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
J. Walkenbach w 'Programowaniu excela' przedstawia sprytne rozwiązanie na uniknięcie powtarzanych wpisów do ListBoxa wykorzystując obiekt Collection oraz argument Key instrukcji Add dodającej elementy do kolekcji.
Sub UsunDuplikaty()
Dim WszystkieKOm As Range, Komórka As Range, myrange As Range
Dim BezPowtórzeń As New Collection
Set myrange = Range("A1:A100")
On Error Resume Next
For Each Komórka In myrange
BezPowtórzeń.Add Komórka.Value, CStr(Komórka.Value)
Next Komórka
On Error GoTo 0
'dodaje unikalne lementy do listboxa
For Each element In BezPowtórzeń
UserForm1.ListBox1.AddItem element
Next element
UserForm1.Show
End Sub
Strona główna > Makra VBA > Przykłady > Makro działające po wybraniu określonej komórki
Jak przypisać makro do entera, a dokładnie chodzi mi o to, by makro działało tylko wtedy, gdy aktywowana będzie dowolna komórka w kolumnie B.
Kod należy wpisać do odpowiedniego arkusza:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
nrkoloumny = 2 'numer kolumny - B=2
If Target.Column = nrkolumny Then
MsgBox "Działa!" 'tutaj Twoje Makro
End If
End Sub
Aby dodać przy pomocy VBA nową pozycję menu:
Sub dodaj_NoweMenu()
'dodaje NoweMenu do paska menu
Set NoweMenu = CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, before:=10)
'before:=10 - określa w którym miejscu wstawia NoweMenu
NoweMenu.Caption = "&NoweMenu"
'dodaje pozycję do nowego menu
Set poz1 = NoweMenu.Controls.Add
With poz1
.Caption = "&Poz1"
.OnAction = "mojemakro5"
.FaceId = 160
End With
'dodaje pozycję rozwijaną do menu NoweMenu
Set poz2 = NoweMenu.Controls.Add(Type:=msoControlPopup)
With poz2
.Caption = "&Poz2"
End With
Set podpoz1 = poz2.Controls.Add
With podpoz1
.Caption = "&Podpoz1"
.Style = msoButtonIconAndCaption
.OnAction = "mojemakro3"
.FaceId = 1096
End With
Set podpoz2 = poz2.Controls.Add
With podpoz2
.Caption = "&Podpoz2"
.Style = msoButtonIconAndCaption
.OnAction = "mojemakro4"
.FaceId = 126
End With
'rozpoczyna grupę dla Poz2
poz2.BeginGroup = True
End Sub
Kod usuwający nasze menu:
Sub usun_NoweMenu()
On Error GoTo koniec
Set NoweMenu = CommandBars("Worksheet Menu Bar").Controls("&NoweMenu")
NoweMenu.Delete
koniec:
End Sub
Zamieszczony tutaj kod zmienia w odstępach co jedną sekundę formatowanie komórki co można wykorzystać do uzyskania efektu migającej czcionki, albo zmieniającego się tła komórki:
Poniższy przykład zmienia formatowanie jak na zdjęciach powyżej.
Private zmiana As Boolean
Sub UpdateClock()
Dim zakres As Range
Set zakres = Range("A1")
If zmiana Then
zakres.Interior.ColorIndex = xlNone
zakres.Font.Color = vbBlack
Else
zakres.Interior.Color = vbBlack
zakres.Font.Color = vbWhite
End If
zmiana = Not zmiana
NextTick = Now + TimeValue("00:00:01")
Application.OnTime NextTick, "UpdateClock"
End Sub
Trochę to dziwne, ale chyba nie ma właścowości zwracającej nazwę kolumny w postaci literowej.
Poniższy kod zwraca nazwy kolumn zaznaczonego zakresu w postaci literowej:
Sub nazwa_kolumny()
Dim mrange As Range
Set mrange = Selection
kolumny = ""
For Each komorka In mrange
nazwa = Application.Substitute(Cells(1, komorka.Column).Address(False, False), "1", "")
kolumny = kolumny & " " & nazwa
Next komorka
MsgBox kolumny
End Sub
Kod poniższej funkcji zwraca nazwę komputra (makro nadesłane przez Henryka Tomczyka):
Option Explicit
Private Declare Function GetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Sub Get_Computer_Name()
Dim Comp_Name_B As String * 255
Dim Comp_Name As String
GetComputerName Comp_Name_B, Len(Comp_Name_B)
'ciąg jest zawsze zakończony ciągiem zerowym, więc
' można użyć funkcji Chr(0) do znalezienia końca
Comp_Name = Left(Comp_Name_B, InStr(Comp_Name_B, Chr(0)))
'i zwrócenia tylko nazwy komputera
MsgBox Comp_Name
End Sub
Kod poniższej funkcji zwraca nazwę zalogowanego użytkownika (kod pochodzi z samples.xls):
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, _
nSize As Long) As Long
Sub Get_User_Name()
Dim lpBuff As String * 25
Dim ret As Long, UserName As String
ret = GetUserName(lpBuff, 25)
UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
MsgBox UserName
End Sub
Strona główna > Makra VBA > Przykłady > Numeracja strony bezpośrednio w arkuszu
Procedura autorstwa Henryka Tomczyka pobrana z grup dyskusyjnych. Umieszczam ją za zgodą autora. Trochę zmodyfikowałem kod, tak aby numer strony był wyświetlany także na ostatniej niepełnej stronie.
Procedura wstawia numer strony bezpośrednio w arkuszu, w lewym dolnym rogu strony.
Sub nr_str_na_dole_strony()
'autor Henryk Tomczyk [htomczyk@wp.pl]
'za zezwoleniem autora
a = 0: b = 1
m = Worksheets.HPageBreaks.Count
n = Worksheets.VPageBreaks.Count + 1
aa = Worksheets.HPageBreaks(1).Location.Row
For i = 1 To n
For j = 1 To m
a = a + 1
Worksheets.HPageBreaks(j).Location.Offset(-1, b - 1). _
FormulaR1C1 = "Str. " & a & "/" & (m + 1) * n
Next j
Worksheets.HPageBreaks(j - 1).Location.Offset(aa - 2, b - 1). _
FormulaR1C1 = "Str. " & a + 1 & "/" & (m + 1) * n
a = a + 1
If i <= n - 1 Then
b = Worksheets.VPageBreaks(i).Location.Column
Else
Exit Sub
End If
Next i
End Sub
Istnieje czasem potrzeba dialogu z użytkownikiem w postaci pytania o folder.
Poniższy kod zawiera deklarację odpowiedniej funkcji API (32-bit) oraz funkcji użytkownika zwracającej w postaci ciągu znaków wskazaną przez nas ścieżkę (przykład pochodzi z samples.xls):
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Function PobierzFolder(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim ścieżka As String
Dim r As Long, x As Long, pos As Integer
' Folder główny - Pulpit
bInfo.pidlRoot = 0&
' Tytuł okna dialogowego
If IsMissing(Msg) Then
bInfo.lpszTitle = "Wybierz folder"
Else
bInfo.lpszTitle = Msg
End If
' Typ zwracanego foldera
bInfo.ulFlags = &H1
' Wyświatlanie okna dialogowego
x = SHBrowseForFolder(bInfo)
' Analiza zwróconej wartości
ścieżka = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal ścieżka)
If r Then
pos = InStr(ścieżka, Chr$(0))
PobierzFolder = Left(ścieżka, pos - 1)
Else
PobierzFolder = ""
End If
End Function
Tak wygląda wyświetlane okno:
Aby dodać nowy pasek zadań:
Sub dodaj_pasek()
Dim NewToolbar As CommandBar
Dim NewButton As CommandBarButton
' usuwa pasek jeżeli istnieje
On Error Resume Next
Application.CommandBars("NowyPasek").Delete
On Error GoTo 0
' dodaje pusty pasek
Set NewToolbar = Application.CommandBars.Add _
(Name:="NowyPasek", temporary:=True)
NewToolbar.Visible = True
' dodaje przycisk
Set NewButton = NewToolbar.Controls.Add _
(Type:=msoControlButton)
NewButton.FaceId = 1015
NewButton.Caption = "NowyPrzycisk"
NewButton.OnAction = "mojemakro"
Set NewButton = NewToolbar.Controls.Add _
(Type:=msoControlButton)
NewButton.FaceId = 160
NewButton.Caption = "KolejnyNowyPrzycisk"
NewButton.OnAction = "m0jemakro2"
'pozycja paska
NewToolbar.Position = msoBarTop
End Sub
FaceID - numer ikony w zestawie ikon excela - patrz więcej ikon.
Kolejna procedura usuwa nasz pasek:
Sub usun_pasek()
'usuwa pasek
Application.CommandBars("NowyPasek").Delete
End Sub
Poniższy przykład pokazuje jak za pomocą kodu VBA można napisać ... kod VBA. Procedura usuwa z zeszytu test.xls (zakłądm, że jest on otwarty) z Module1 cały tekst (o ile istnieje) i wpisuje nowy:
Sub wstaw_kod()
Dim wb As Workbook
Set wb = Workbooks("test.xls")
Set vbp = wb.VBProject
Set m = vbp.VBComponents("Module1")
'usuwa dotychczasowy tekst makra
On Error Resume Next
usun = m.CodeModule.DeleteLines(1, m.CodeModule.CountOfLines)
'pisze kod
code = "Sub makro()" & vbCr
code = code & "MsgBox (thisworkbook.name & "" - to działa!"")" & vbCr
code = code & "End Sub"
'wstawia kod do Module1
With vbp. _
VBComponents("Module1").CodeModule
nextline = .CountOfLines + 1
.InsertLines nextline, code
End With
End Sub
Konieczne jest włączenie dostępu do projektu VB: menu excela narzędzia/makra/bezpieczeństwo/zaufane źródła, zaznaczyć 'ufaj dostęowi do projektu VB' (tłumaczenie własne).
Procedurę można wykorzystać np. do uaktualnienia kodów makr w zeszytach do których nie mamy bezpośredniego dostępu, prosząc ich operatorów o uruchomienie zeszytu z 'aktualizatorem makr'.
Strona główna > Makra VBA > Przykłady > Pisanie kodu kodem - przypisanie zdarzenia dodanej kodem kontrolce
Poniższy przykład pokazuje jak za pomocą kodu VBA można napisać ... kod VBA. Procedura dodaje do aktywnego skoroszytu kontrolkę CheckBox, a następnie tworzy kod obsługujący zdarzenie 'Click':
Sub wstawCheckBox()
Dim arkusz As Worksheet
Set arkusz = ActiveSheet
'dodaje kontrolkę
Set NewCheckBox = arkusz.OLEObjects.Add(ClassType:="Forms.CheckBox.1")
nazwa = NewCheckBox.Name
NewCheckBox.Object.Caption = nazwa
'pisze kod
code = "Sub " & nazwa & "_Click()" & vbCr
code = code & "MsgBox (me." & nazwa & ".name & "" - to działa!"")" & vbCr
code = code & "End Sub"
'wstawia kod do arkusza
With ThisWorkbook.VBProject. _
VBComponents(arkusz.Name).CodeModule
nextline = .CountOfLines + 1
.InsertLines nextline, code
End With
End Sub
Konieczne jest włączenie dostępu do projektu VB: menu excela narzędzia/makra/bezpieczeństwo/zaufane źródła, zaznaczyć 'ufaj dostęowi do projektu VB' (tłumaczenie własne).
Procedura pochodzi z książki J. Walkenbacha "Programowanie Excel 2000". Mojego autorstwa są (niestety) poprawki i drobne zmiany w kodzie.
Wprowadzając dane do pewnego arkusza musiałem mieć podgląd co znajduje się w komórce o takim samym adresie, ale w innym arkuszu (miał on nazwę 'Dane'). Ponieważ nie znam, żadnej wbudowanej funkcjonalności excela wykonującej to zadanie wykorzystałem okno komunikatu 'sprawdzania poprawności danych' oraz proste makro:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim mysheet As Worksheet
Dim tekst As String
Set mysheet = Sheets("Dane") 'tutaj definiujemy z którego arkusza chcemy podglądać dane
tekst= "Tekst komórki " & mysheet.Name & "!" & Target.Address & ": ''" 'tutaj definiujemy
'dodatkowy tekst jaki pojawi się w komunikacie
tekst = tekst & mysheet.Range(Target.Address).Text & "''"
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop
.InputMessage = tekst
End With
End Sub
Kod makra wstawiamy oczywiście w tym arkuszu, w którym chcemy uzyskać efekt.
W praktyce wygląda to tak:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object,_
ByVal Target As Excel.Range)
Static OldRange As Range
On Error Resume Next
Target.Interior.ColorIndex = 6 ' yellow - change as needed
OldRange.Interior.ColorIndex = xlColorIndexNone
Set OldRange = Target
End Sub
Udało mi się zmodyfikować kod tak, aby uwzględniał dotychczasowe formatowanie (kolor) komórki:
Public oldrange As Range, oldcolor As Single
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As _ Excel.Range)
On Error Resume Next
oldrange.Interior.ColorIndex = oldcolor
oldcolor = Target.Interior.ColorIndex
Target.Interior.ColorIndex = 6 ' yellow - change as needed
Set oldrange = Target
End Sub
Kolejny wariant kodu, nadesłany przez kolegę Janusza. Format nie jest zmieniany jeżeli komórka ma inny kolor niż "żaden", formatowanie jest usuwane w przypadku zamknięcia zeszytu, lub zmiany arkusza.
Public oldrange As Range, oldcolor As Single
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
If ActiveCell.Interior.ColorIndex = 6 Then
ActiveCell.Interior.ColorIndex = xlNone
End If
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
If ActiveCell.Interior.ColorIndex = 6 Then
ActiveCell.Interior.ColorIndex = xlNone
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If Target.Interior.ColorIndex = xlNone Then
oldrange.Interior.ColorIndex = oldcolor
oldcolor = Target.Interior.ColorIndex
Target.Interior.ColorIndex = 6
Set oldrange = Target
End If
End Sub
Procedura sortuje arkusze w aktywnym zeszycie.
Sub SortujArkusze()
Application.ScreenUpdating = False
Dim i, j
Dim ActWork As Worksheet
Dim ActRan As Range
Dim najmn As Worksheet
Set ActWork = ActiveSheet
Set ActRan = Selection
Set najmn = Sheets(1)
For i = 1 To Sheets.Count
For j = i To Sheets.Count
If Sheets(j).Name < najmn.Name Then
Set najmn = Sheets(j)
End If
najmn.Move before:=Sheets(i)
Next
On Error GoTo blad
Set najmn = Sheets(i + 1)
Next
blad: ActWork.Activate
ActRan.Select
End Sub
Strona główna > Makra VBA > Przykłady > Sortowanie znaków w ciągu
Dwa przykłady kodów VBA nadesłane przez Henryka Tomczyka.
Kod sortuje znaki w ciągu, wynik jest umieszczany w komórce na prawo od zawierającej sortowane znaki:
Sub Sortowanie_znaków_ciagu()
czy = MsgBox("Czy zaznaczono komórkę do sortowania znaków?" & Chr(13) _
& " (- wynik w komórce na prawo)", vbYesNo)
If czy = 7 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Selection.Copy: Sheets.Add.Name = "aa" ' bo może brak miejsca w Arkusz1 ?
Range("A1").PasteSpecial Paste:=xlValues
Range("B1").Select
Range("C1") = "=LEN(""" & Range("A1") & """)"
dlug = Range("C1"): For a = 1 To dlug
Selection = "=MID(""" & Range("A1").Value & """," & a & ",1)"
Range("B1").Offset(a, 0).Select: Next a
Columns("B").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("D1").Select: For a = 1 To dlug
Selection = Selection.Value & Range("B1").Offset(a - 1, 0).Value
Next a: Selection.Copy
Sheets("Arkusz1").Select
Selection.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlValues
Sheets("aa").Delete
Application.ScreenUpdating = True
End Sub
Drugi kod to funkcja użytkownika sortująca znaki wg tablicy:
Option Base 1
Public Function SortLiter(wyraz As String) As String
Dim TablicaLiter
Dim TablicaWyników(35) As String
Dim DłCiągu As Long
Dim i, j As Long
'poniższa kolejność znaków decyduje o sortowaniu - można ją zmienić !!!
TablicaLiter = Array("a", "ą", "b", "c", "ć", "d", "e", "ę", "f", "g", "h", "i", "j", "k", "l", _
"ł", "m", "n", "ń", "o", "ó", "p", "q", "r", "s", "ś", "t", "u", "v", "w", "x", "y", "z", "ź", "ż")
DłCiągu = Len(wyraz)
For i = 1 To DłCiągu
For j = 1 To 35
If LCase(Mid(wyraz, i, 1)) = TablicaLiter(j) Then
TablicaWyników(j) = TablicaWyników(j) & Mid(wyraz, i, 1)
Exit For
End If
Next j
Next i
For j = 1 To 35
SortLiter = SortLiter & TablicaWyników(j)
Next j
End Function
Zaznaczenie kilku komórek zawierających wartości powoduje wyświetlenie ich sumy w pasku stanu. Ale jak sprawić by excel pamiętał tę sumę i pozwalał ją wkleić do komórki? Byłem kiedyś w takiej potrzebie i napisałem następujący kod:
Public suma
Sub licz_sume()
suma = 0
Dim mrange As Range
Set mrange = Selection
For Each komorka In mrange
If IsNumeric(komorka.Value) = True Then
suma = suma + komorka.Value
End If
Next
Application.OnKey "^z", "zwroc_sume"
Application.StatusBar = "Suma wynosi: " & suma
End Sub
Sub zwroc_sume()
Selection.Value = suma
Application.OnKey "^z", "licz_sume"
Application.StatusBar = False
End Sub
Sub auto_open()
Application.OnKey "^z", "licz_sume"
End Sub
Działa to w następujący sposób: zaznaczamy interesujący nas obszar, naciskamy "ctrl+z", przechodzimy do komórki, w którą chcemy wkleić sumę i ponownie naciskamy "ctrl+z".
Jeżeli chcemy by był to inny klawisz w linii Application.OnKey "^z", "licz_sume" zamieńmy literę "z" na inną.
Poniższy przykład tworzy w aktywnym arkuszu począwszy od komórki A1 spis zawartości folderu (zmienna "fold"):
Sub spis()
Dim mrange
fold = "C:\"
f = Dir(fold, vbDirectory)
Set mrange = Range("A1")
mrange.Value = f
Do While f <> ""
f = Dir
If f <> "" Then
Set mrange = mrange.Offset(1, 0)
mrange.Value = f
End If
Loop
End Sub
Kolejna procedura różni się od poprzedniej tym, że wstawia hyperlinki zamiast samych nazw zawartości folderu:
Sub spis_hyperlinki()
Dim mrange
fold = "C:\"
f = Dir(fold, vbDirectory)
Set mrange = Range("A1")
mrange.Value = f
ActiveSheet.Hyperlinks.Add Anchor:=mrange, Address:=fold & f, _
TextToDisplay:=f
Do While f <> ""
f = Dir
If f <> "" Then
Set mrange = mrange.Offset(1, 0)
ActiveSheet.Hyperlinks.Add Anchor:=mrange, Address:=fold & f, _
TextToDisplay:=f
End If
Loop
End Sub
Rozwiązanie znalezione na grupach dyskucyjnych - przełącza textboxa w tryb nadpisywania:
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If TextBox1.SelLength = 0 Then
TextBox1.SelLength = 1
End If
End Sub
Nie jest możliwe bezpośrednie uruchomienie makra formułą, czyli nie jest możliwa następująca formuła:
=JEŻELI(B1="xyz";MAKRO1;MAKRO2)
Można natomiast pokusić się o zrobienie tego w sposób "na okrętkę":
1, powyższa formuła (zakładam, że wpisana jest w komórce A1) powinna wyglądać np. tak:
=JEŻELI(B1="xyz";1;0)
2, W kodzie arkusza należy wpisać:
Private Sub Worksheet_Calculate()
sprawdz = Range("A1").Value
Select Case sprawdz
Case 1
Call Makro1 'tutaj nazwa makra jeżeli wartość Prawda naszej formuły
Case 0
Call Makro2 'tutaj nazwa makra jeżeli wartość Fałsz naszej formuły
End Select
End Sub
Teraz każde przeliczenie arkusza (a więc i zmiana wartości w komórce A1 (tam gdzie nasza formuła)) spowoduje uruchomienie kodu - sprawdzenie wartości w komórce A1 i uruchomienie odpowiedniego makra!
Funkcja użytkownika będąca kompozycją =SUMY.POŚREDNIE() i =SUMA.JEŻELI() umożliwaijąca warunkowe zsumowanie wartości z pominięciem ukrytych komórek (za pomocą filtra bądź ukrywania):
Function suma_jezeli_widoczne(zakres_suma As Range, kryterium, zakres_kryterium As Range)
suma_jezeli_widoczne = 0
sumuj = 0
licz = 0
For Each komorka In zakres_suma
licz = licz + 1
If komorka.EntireRow.Hidden = False And zakres_kryterium.Cells(licz) = kryterium Then
sumuj = sumuj + komorka.Value
End If
Next
suma_jezeli_widoczne = sumuj
End Function
Alternatywnie możemy posłużyć się następującą formułą (komórka A13 z rysunku):
=SUMA.ILOCZYNÓW((B2:B10=B13)*SUMY.POŚREDNIE(9;PRZESUNIĘCIE($A$10;WIERSZ(A2:A10)-WIERSZ(A10);0;1;1)))
Excel posiada znacznie więcej ikon niż wynika to ze standardowych pasków zadań i z zestawu ikon w oknie "dostosuj pasek zadań". Aby się do nich dobrać potrzebujemy makro (procedura była gdzieś dawno temu wyszperana, niestety nie pamiętam gdzie, stąd przepraszam, że nie podaję źródła):
Sub ShowFaceIDs()
Dim NewToolbar As CommandBar
Dim NewButton As CommandBarButton
Dim i As Integer, IDStart As Integer, IDStop As Integer
' usuwa pasek nowych ikon o ile istnieje
On Error Resume Next
Application.CommandBars("FaceIds").Delete
On Error GoTo 0
' dodaje pusty pasek
Set NewToolbar = Application.CommandBars.Add _
(Name:="FaceIds1", temporary:=True)
NewToolbar.Visible = True
' następujące wartości należy zmienić w zależności od potrzeb
IDStart = 1
IDStop = 500
For i = IDStart To IDStop
Set NewButton = NewToolbar.Controls.Add _
(Type:=msoControlButton, ID:=2950)
NewButton.FaceId = i
NewButton.Caption = "FaceID = " & i
Next i
NewToolbar.Width = 600
Application.CommandBars("FaceIds1").Visible = False
End Sub
Procedura tworzy pasek o nazwie "FaceIds" - teraz możemy sobie kopiować ikonki przycisków.
Efekt dla zestawu pierwszych 600 ikon jest następujący:
Imponujące! Ja doszedłem do 3600. Aby pooglądać sobie kolejne zestawy należy manipulować wartościami IDStart i IDStop w kodzie procedury. Polecam jednak zawsze pozostać z liczbą 600 ikon w zestawie (czyli wartości IDStart i IDStop odpowiednio powinny przybierać wartości 1 i 600, 601 i 1200, itd.) - już taki pasek tworzy się dość długo, a co dopiero zawierający znacznie więcej elementów!
Dodam jeszcze, że wiele ikon się powtarza, a niektóre są "puste".
Dla tych, którzy pracują klawiaturą może okazać się, że nie wystarczające są dostępne klawisze skrótów, ale od czego VBA? Możemy sobie sami stworzyć własne klawisze skrótów wykonujące czynności jakie tylko nam się zamarzy. Wystarczy tylko przypisać klawisz skrótu do makra: menu: "narzędzia/makro/makra" wybieramy nazwę makra, do którego chcemy przypisać klawisz i naciskamy przycisk "opcje" i wybieramy literę skrótu.
Najczęściej używane przeze mnie osobiście własne klawisze skrótów, to:
Ctrl+Q - wklej wartości:
Sub wklejspecjalnie()
Selection.PasteSpecial Paste:=xlPasteValues
End Sub
Ctrl+A - wklej formuły:
Sub wklejspecjalnie()
Selection.PasteSpecial Paste:=xlPasteFormulas
End Sub
Ctrl+E - zaznacz wiersz na żółto i przejdź do komórki poniżej, jeśli już zaznaczony na ten kolor to brak wypełnienie, często potrzebuje taki klawisz przy sprawdzaniu jakichś danych, odznaczam sobie wtedy te wiersze, które już sprawdziłem:
Sub zaznaczwiersz()
If Selection.Interior.ColorIndex <> 36 Then
Selection.EntireRow.Interior.ColorIndex = 36
Else
Selection.EntireRow.Interior.ColorIndex = xlNone
End If
Selection.Offset(1, 0).Select
End Sub
Ctrl+L szybkie otwarcie pewnego, często używanego szablonu:
Sub otworz()
Workbooks.Open Filename:="C:\My Documents\Spis.xlt"
End Sub
Ctrl+Z Kopiuje sumę zaznaczonych komórek do schowka i następnie umożliwia wklejenie sumy jako jednej liczby do innej komórki - patrz: Sumowanie wartości komórek przez kopiowanie.
Nie ma, przynajmniej w standardowym zestawie kontrolek, kontrolki pozwalającej na wyświetlenie wykresu na formularzu użytkownika. Zastęcze rozwiązanie proponuje John Walkenbach na stronie http://j-walk.com/ss/excel/tips/tip66.htm.
Ideą jest zapisanie istniejącego w arkuszu wykresu w postaci gifa i wstawienie go do kontrolki Image.
Zaczynamy od stworzenia tradycyjnego wykresu:
Kod:
Sub wykres()
'zapisuje wykres w postaci gif
Set CurrentChart = Sheets("Sheet1").ChartObjects(1).Chart
Fname = ThisWorkbook.Path & "\temp.gif"
CurrentChart.Export Filename:=Fname, FilterName:="GIF"
'wstawia zapisany gif do kontrolki Image
UserForm1.Image1.Picture = LoadPicture(Fname)
'wyświetla formularz
UserForm1.Show
End Sub
Zapisuje wykres w postaci pliku gif i wstawia go do formularza użytkownika (uwaga na nazwę formularza i kontrolki Image!)
Jeżeli regularnie przesyłamy zestawienia, raporty lub inne informacje powstające w excelu e-mailem możemy naszą pracę usprawnić - excel może za nas stworzyć i wysłać emaila.
Poniższy kod wysyła aktywny arkusz jako załącznik korzystając z domyślnego klienta poczty:
Sub wyslij_email()
'wysyła aktywny arkusz jako załącznik
wyslij = Application.Dialogs(xlDialogSendMail).Show("excel@autograf.pl", "temat")
End Sub
Jeżeli mamy MSOutlooka możemy skorzystać z odwołania do jego biblioteki - mamy wtedy znacznie większe możliwości kształtowania naszej wiadomości. Poniższy kod wysyła e-maila za pomocą MSOutlooka (zmodyfikowany kod pochodzi z samples.xls):
Sub wyslij_emaila()
' <<< important! >>>
'For this example click References on the Tools Menu, and select the
'Microsoft Outlook 9.0 object libraries.
Dim ol As Object, myItem As Object
'Create a Microsoft Outlook session
Set ol = CreateObject("outlook.application")
'Create a mail
Set myItem = ol.CreateItem(olMailItem)
'Add information to the new mail
adresat = "excel@autograf.pl" 'adresat wiadomości, jeśli wielu oddzielamy znakiem separacji ;
temat = "Temat wiadomości" 'tutaj temat wiadomości
tresc = "Treść linia 1" & vbCr & "treść linia 2"
zalacznik = "C:\Raport.xls"
With myItem
.To = adresat
.Subject = temat
.Body = tresc
.NoAging = True
.ReadReceiptRequested = False 'True jesli chcesz by przesłano potwierdzenie odczytu
.OriginatorDeliveryReportRequested = False 'True jesli chcesz by potwierdzenie odbioru
.Attachments.Add zalacznik
.Send ' Save jeśli chcesz zapisać w draft
End With
'Remove object from memory
Set ol = Nothing
End Sub
Osobiście wykorzystuję ten kod do dystrybucji informacji o wprowadzeniu nowego klienta do sytemu księgowego - zakres informacji oraz odbiorcy są standardowi zmienia się tylko treść, więc pobieram excelem z bazy danych systemu księgowego potrzebne informacje i wysyłam je powyższym kodem - nie muszę więc sam pisać emaila. Drugim zastosowaniem jest wysłanie cotygodniowego raportu. Raport jest przygotowywany w excelu na podstawie danych zaksięgowanych w systemie FK, w odpowiednim terminie naciskam tylko jeden przycisk - raport tworzy się w odpowiednim formacie sam i sam się wysyła korzystając z powyższego kodu.
Przy pomocy makra VBA można zablokować możłiwość wydrukowania arkusza:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
If ThisWorkbook.ActiveSheet.Name <> "" Then Cancel = True
End Sub
Warunek sprawdzający " <> "" "będzie zawsze przyjmował wartość "prawda" (nie można nadać pustej nazwy dla arkusza) stąd nie będzie możliwe wydrukowanie żadnego z arkuszy zeszytu. Jeżeli chcemy by nie był drukowany określony arkusz pomiędzy znaki cudzysłowiu wstawmy nazwę arkusza. Oczywiście nazwę można zmienić i wtedy procedura nie zadziała - ale jest i nato sposób - ochrona struktury zeszytu (narzędzia/ochrona/chroń arkusz).
Strona główna > Makra VBA > Przykłady > Zablokowanie możliwości wprowadzenie więcej niż jednego określonego znaku to TextBoxa
Poniższy kod uniemożliwia wprowadzenie po raz drugi i kolejny określonego
znaku (zmienna 'znak') do TextBoxa:
Private Sub TextBox1_Change()
znak = "a" ''znak' ktory moze byc wprowadzony tylko 1 raz
licz = 0
For i = 1 To Len(TextBox1)
'sprawdza ile razy wystepuje 'znak'
If Mid(TextBox1, i, 1) = znak Then
licz = licz + 1
End If
Next i
'jezeli znak wystepuje juz 1 raz i wprowadzony znak to 'znak' - usuwa go
If licz > 1 And Right(TextBox1, 1) = znak Then
TextBox1 = Left(TextBox1, Len(TextBox1) - 1)
End If
End Sub
Otrzymałem także, pocztą elektroniczną zaproponowane przez czytelnika prostsze i czytelniejsze rozwiązanie:
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Chr(KeyAscii) = "a" Then
If InStr(1, TextBox1.Text, "a") > 0 Then
KeyAscii = 0
End If
End If
End Sub
A także kod umożliwiający wprowadzenie każdego ze znaków tylko jeden raz:
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If InStr(1, TextBox1.Text, Chr(KeyAscii)) > 0 Then
KeyAscii = 0
End If
End Sub
Zdarzało mi się kilkarotnie, że zaimportowany lub skopiowanay do excela tekst w przypadku liczb miał postać '10 000'. Excel traktował go jako tekst, a nie liczbę z powodu spacji. Jednakże usunięcie spacji okazało się niemożliwe za pomocą standardowego 'znajdź/zamień'. Okazało się, że spacja ma kod ASCII 160, a nie 32 jak standardowa spacja. Pomocne okazało się proste makro zamieniające w zaznaczonym obszarze spacje. Starłem się napisać je trochę bardziej uniwersalnie, tak by łatwo można było za zmienne podstawić kody znaków.
Sub zamien_znaki()
zamien_z = 160
zamien_na = 32
For Each komorka In Selection
komorka.Formula = Replace(komorka.Formula, Chr(zamien_z), Chr(zamien_na))
Next komorka
End Sub
Istnieje pewien sposób zmuszenia użytkownika zeszytu do jego otwarcia z uruchomionymi makrami. Należy posłużyć się następującymi kodami:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheets("Sheet1").Visible = xlVeryHidden
End Sub
Private Sub Workbook_Open()
Sheets("Sheet1").Visible = True
End Sub
Kluczem jest tu parametr xlVeryHidden - jego użycie spowoduje ukrycie arkusza, ale nie będzie on widoczny na liście arkuszy ukrytych (menu: "format/arkusz/odkryj") i użytkownik nie będzie w stanie go odkryć z poziomu menu excela. W tak ukrytym arkuszu (czy arkuszach) umieszczamy wszystko co jest kluczowe dla obsługi zeszytu. Natomiast odkryty arkusz (nie można wszystkich arkuszy ukryć) może informować, że aby pracować w zeszycie musi być on otwarty z uruchomionymi makrami.
Oczywiście jest to zabezpieczenie tylko przed tymi użytkownikami, którzy nie znają VBA - można przecież tak ukryty arkusz odkryć kodem VBA z poziomu innego zeszytu.
Wyszukiwarka
Podobne podstrony:
Strona główna kursu Vba, excel
Strona główna 03 2013
0) STRONA GŁÓWNA
PJM Strona Główna poziom A2
strona główna
strona główna
Przedmiot Humanistyczny, Realizm Kościoła katolickiego w czasach PRL-u - FULL, [ Strona główna
Fizyczna strona główna czysta, CHEMIA FIZYCZNA SPRAWKA 4 SEM
sytuacja kryzysowa - strona glowna, WSZiP (UTH) Heleny Chodkowskiej BEZPIECZEŃSTWO WEWNĘTRZNE, IV se
Strona główna
Ceramika strona główna
Strona glowna
strona główna
Strona Główna na Referaty z Silników
Strona główna, Prace dypl + inż, Praca Dypl
strona główna
więcej podobnych podstron