VBA Tools

Od jakiegoś czasu użytkuje telefon z nowym systemem Microsoftu WP7.5. Chciałem się z wami podzielić kilkoma spostrzeżeniami.

Do ręki wpadł mi model Samsung Omnia W z pow. systemem, jednakże przeglądając oferty operatorów można zauważyć iż coraz więcej słuchawek promuje ten system. Dlaczego i co przemawia za koniecznością jego posiadania jak i co potrafi zrazić spróbuje przekazać poniżej – ocenicie sami. (czytaj dalej …)

Zamiana nagłówków tabeli danych to dość trywialny temat, często spotykany po pozyskaniu danych z qwerendy, gdzie nie zmieniamy ich w zapytaniu SQL.

Można podpiąć podobną procedurę po odświeżeniu tabeli przestawnej w procedurze zdarzeniowej lub po imporcie wymuszonej kodem.

Oto kod:

Sub zamien_nazwy_naglowkow()
'MVP Oskar Shon from VBATools.pl
Dim rng As Range
'od komórki A1 do ostatniej w wierszu 1
Set rng = Range(Cells(1, 1), Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column))
'Set rng = Range("a4:z4") 'przykład innego zakresu
On Error Resume Next

'zmiana nazw
Cells(1, rng.Find("nazwa_kol").Column) = "Nowa nazwa"
Cells(1, rng.Find("inna nazwa").Column) = "Nowa inna nazwa"
'rng.Replace "nazwa_kol", "Nowa nazwa", xlWhole 'inny sposób

'zmiana znaków np: "_" w zadanym zakresie
rng.Replace "_", " ", xlPart
Set rng = Nothing
End Sub

oraz pow przykład, który obrazuje działanie kodu.

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

W programie Excel można użyć mechanizmu wbudowanego o nazwie „Tekst jako kolumny”. Gorzej jest z połączeniem danych. Nie ma takiej opcji w interfejsie Excela.

Poleca ci w takim razie małą procedurkę VBA do oddzielenia i połączenia jakichkolwiek danych w zakresie.

Podzielenie:

Sub podziel()
Call Seperate(Selection, ",")  'range("a1:a7"), ",", True
End Sub

Sub Seperate(zakr As Range, seperator As String, _
 Optional kill_spaces As Boolean)
Dim el As Range, ile&, x&, s$
With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With
For Each el In zakr
 s = el.Value
 If InStr(1, s, seperator) > 0 Then
 ile = UBound(Split(s, seperator))
 For x = ile To 0 Step -1
 If kill_spaces Then
 el.Offset(, x).Value = Trim(Split(s, seperator)(x))
 Else
 el.Offset(, x).Value = Split(s, seperator)(x)
 End If
 Next x
 End If
Next el
With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With
End Sub

Połączenie:

Sub polacz()
Call Join_str(Selection, ",")  'range("a1:d7"), ",", True
End Sub

Sub Join_str(zakr As Range, seperator As String, _
 Optional empty_too As Boolean)
Dim x&, y&, tresc$
With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With
For y = 0 To zakr.Rows.Count - 1
 For x = 1 To zakr.Columns.Count
 If empty_too = False Then
 If Len(Trim(Cells(zakr.Row + y, zakr.Column + x - 1).Text)) = 0 Then GoTo dalej
 End If
 tresc = tresc & seperator & Cells(zakr.Row + y, zakr.Column + x - 1).Text
 Cells(zakr.Row + y, zakr.Column + x - 1).ClearContents
 Cells(zakr.Row + y, zakr.Column) = Right$(tresc, Len(tresc) - Len(seperator))
dalej:
 Next x
 tresc = ""
Next y
With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With
End Sub

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

Pojawił się nowy pomysł na ataki osób angażujących się w sprzedaż/zakup na największym, polskim portalu aukcyjnym Allegro.

Pomysłowość godna podziwu, jednakże skutki opłakane. Spamerzy jak i osoby atakujące wzięły się na sposób aby zamiast robotów generujących słownikowe zlepki przesyłać na adresy pozyskane ze słabo zabezpieczonych baz maile o ściśle określonym tekście: „Kupiłam od Państwa…” (czytaj dalej …)

Zastanawiacie się jak dodać tekst do istniejącego już dokumentu?

Otóż nic prostszego, jak użyć Ctrl+H i zastąpienie frazy, ta samą frazą + dodatkowymi wyrazami. Problem stanowi jednak dodanie znaku nowej linii, ponieważ nie jest ona możliwa tą metodą. Należy w tym celu sięgnąć do VBA. Poniżej znajduje się trywialny przykład ilustrujący taką edycje.

Pierwsza procedura tworzy tekst dokumentu (jaki możecie sobie darować) oraz wywołanie drugiej procedury z parametrami warunków osadzenia nowego tekstu.

Kd bez trudu można dopracować pod kątem dodania tekstu do każdego wyrazu lub podania do którego w kolejności ma być dodana pożądana fraza.

Sub Add_text()
ActiveDocument.Select
Selection.Text = "Ala ma kota" & vbNewLine & "a kot ma Ale" & vbNewLine & "itd"

Call dodaj_tresc("ma kota", "Wacka", True, False, False)
End Sub

Sub dodaj_tresc(co_szukamy$, co_wsadzamy$, _
 Optional z_tylu As Boolean, Optional z_przodu As Boolean, _
 Optional wszystkie As Boolean)
Dim doc As Document, gdzie&, zt, zp
If z_tylu = True Then zt = vbNewLine
If z_przodu = True Then zp = vbNewLine

Set doc = ActiveDocument
If wszystkie = True Then
 With Selection.Find
 .Text = co_szukamy
 .Replacement.Text = co_szukamy & zp & co_wsadzamy & zt
 .Wrap = wdFindContinue
 End With
 Selection.Find.Execute Replace:=wdReplaceAll
Else
gdzie = InStr(1, doc.Range.Text, co_szukamy) + Len(co_szukamy)
 If gdzie > 0 Then
   doc.Range(gdzie, gdzie).Select
   Selection.TypeText Text:=zp & co_wsadzamy & zt
   Exit Sub
 End If
End If
End Sub

Kod nadaje się świetnie do rozszerzenia funkcjonalności formularzy.

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora

Przechodzenie pomiędzy arkuszami aktywnych skoroszytów

Oto dodatek, który po uruchomieniu reaguje na otwarte skoroszyty Excela. Przekazuje do niego nazwy arkuszy tych skoroszytów i daje możliwość kliknięcia w strukturze drzewa aby automatycznie przenieść użytkownika do tego arkusza. Jest to mechanizm samo aktualizujący się podczas zmiany nazwy czy dodania nowych arkuszy.

Możliwość przechodzenia jest dość pomocne w przypadku, kiedy użytkujemy wiele plików na raz i poruszanie się po arkuszach niesie za sobą nieusprawiedliwioną utratę czasu. Teraz przejście będzie możliwe za dwoma kliknięciami: skrót wywołujący okno i klikniecie myszy. (czytaj dalej …)

Aktualnie odbywają się przenosiny na nowy serwer. To też mogą wystąpić pewne niedogodności z pobieraniem plików czy komunikacji z portalem.

Proszę o uzbrojenie się w cierpliwość – do jutra problem powinien być zażegnany.

Jeśli w czasie tego okresu nie pojawiły się elementy przez was wstawione proszę wykonać czynność ponownie, a my bierzemy się do pracy….

Poniżej znajduje się kod, który zwraca w oknie immediate [Ctrl+G] nazwy folderów. Ciekawą w jej konstrukcji jest zapętlenie wywołania funkcji, która sama wywołuje „siebie”, aby pobrać dane folderu podrzędnego.

W czym kod ten może być przydatny? Otóż do tworzenia archiwizacji czy eksportu danych do baz danych z zachowaniem pełnej struktury zapisu.

Sub OutlookFolders()
 Dim olNamespace As Outlook.NameSpace
 Dim olFolder As Outlook.Folders
 Dim objFolder As Outlook.MAPIFolder

 Set olNamespace = Application.GetNamespace("MAPI")
 Set olFolder = olNamespace.Folders

 For Each objFolder In olFolder
   Call LoopFolders(objFolder.Folders)
 Next

 Set olNamespace = Nothing
 Set olFolder = Nothing
End Sub

Private Sub LoopFolders(Folders As Outlook.Folders)
 Dim Fold As Outlook.MAPIFolder

 For Each Fold In Folders
   Debug.Print Fold.FolderPath
   DoEvents
   If Fold.Folders.Count Then _
     LoopFolders Fold.Folders 
 Next
End Sub

Rys 1. Lista folderów.

Aby pobrać jedynie nazwę bez ścieżki należy zamiast FolderPath pobrać parametr Name lub w obecnym wymiarze pobrać funkcją InStrRev miejsce znaku „\”

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

Zastanawiacie się jak można wykonać modyfikację pliku, tak aby użytkownik się nie zorientował? Jest wiele metod, począwszy od napisania dodatku który uruchomimy wraz z komputerem lub z autostartem Excela, można podmienić plik po GPO (komputer w domenie) lub uruchomić plik polecenia skryptowego.

Ta porada będzie właśnie poświęcona wykorzystaniem języka skryptowego do modyfikacji istniejącego pliku Excela.

Poniżej znajdziemy treść pliku tekstowego z rozszerzeniem vbs, który z łatwością po odpaleniu zrozumie nasz procesor działający w systemie Windows.

'MVP OShon from VBATools.pl
Dim XLApp 'As Object 'Excel.Application
Dim wkb 'As Object
Dim wks 'As Object
Dim sciezka 'As String
sciezka = "c:\temp\test.xlsx"
Set XLApp = CreateObject("Excel.Application")
 XLApp.Visible = False
 XLApp.Workbooks.Open sciezka
 Set wkb = XLApp.ActiveWorkbook
 Set wks = wkb.Sheets(1)
 wks.Cells(1,1) = "Hello Word"
 wkb.Close True
 XLApp.Quit
 Set wkb = Nothing
 Set wks = Nothing
 Set XLApp = Nothing

Co on właściwie robi?

Otwiera aplikacje Excel w trybie ukrytym, następnie odwołuje się do pierwszego arkusza i modyfikuje komórkę A1 wstawiając tam stringa. Po zakończeniu operacji wyłącza aplikację i czyści pamięć. Można zauważyć że w języku skryptowym nie odwołujemy się określając zmienne – pozostawiamy to procesorowi. Niestety taka forma nie jest mile widziana ani w VB ani VBA, gdzie prędkość działania jest uzależniona od prawidłowej deklaracji.

Aby uruchomić plik *.vbs należy go zapisać i albo umieścić stosowną komendę ze ścieżką jego przetrzymywania w rejestrze użytkownika:

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce

„C:\jakis_katalog\plik.vbs” /nosplash /minimized

albo umieścić plik lub jego link w autostarcie (zwracając uwagę na późniejszą dezintegracje pliku, aby proces ten nie powtarzał się za każdym razem podczas uruchomienia komputera).

Option Explicit
Sub wlaczanie_przypomninia()
'MVP OShon from VBATools.pl
Dim msg$, Response$, q&

msg = "Procedura włączenia przypomnień do terminów w kalendarzu Outlooka" & vbCr & vbCr _
& "Aby kontynuować naciśnij ''Tak''" & vbCr _
& "Aby anulować operacje naciśnij ''Nie''"
On Error GoTo blad
Response = MsgBox(msg, vbYesNo + vbExclamation + vbDefaultButton2, " Aktualizacja dzwoneczków")
If Response = vbYes Then
  Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")
  OutApp.Session.Logon
  Dim oApptFolder As MAPIFolder
    Set oApptFolder = OutApp.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Dim oCalendar As AppointmentItem
Dim olApp As Items
  Set olApp = oApptFolder.Items
  For q = 1 To olApp.Count
    DoEvents
    Set oCalendar = olApp.Item(q)
    If Not oCalendar.Categories = "" _
      And oCalendar.ReminderSet = False _
      And oCalendar.Start >= Now Then
      'Jeśli nie określimy nazwy dla kategorii należy zmienić pow. warunek.
      oCalendar.ReminderSet = True
      oCalendar.Save
    End If
  Set oCalendar = Nothing
Next q
MsgBox "Dzwoneczki uaktywnione!", vbInformation, "O'Shon machine from VBATools."
Set OutApp = Nothing
Set oApptFolder = Nothing
End If
Exit Sub

blad:
MsgBox "Błąd: " & Err.Number & vbCr & Err.Description, vbExclamation
End Sub

Ten prosty przykład uzmysłowi wam jak działa pasek postępu. Elementarnym czynnikiem jest określenie wartości maksymalnej dla paska. W czasie przekazywania kolejnych parametrów, wartość paska będzie „dochodzić” do tej wartości.

Poniżej można znaleźć kod, który otwiera w zadeklarowanym katalogu pliki jakie spełniają określony warunek. Użyta w kodzie metoda FSO pozwala na przekazanie nazwy kolejnego pliku w pętli. Pliki są otwierane i zamykane bez zapisu. Parametr .value jest przekazywany.

Oto prosty przykład jak działa pasek postępu.

rys 1. Pasek postępu przypisany do otwieranych kolejno plików.

Option Explicit
Private Sub UserForm_Initialize()
'Taki sposób nie jest dobry ponieważ kod zacznie działać zanim forma się wyświetli
'Call test_4progres
End Sub

Private Sub CommandButton1_Click()
'to jest dobry sposób - wymuszenie przyciskiem
Call test_4progres
End Sub

Private Sub UserForm_Activate()
'to jest dobry sposób - zadziała zaraz po wywołaniu formy
Call test_4progres
End Sub

Sub test_4progres()
'MVP OShon from VBATools.pl
Const sciezka$ = "C:\Temp\"
Dim ob As Object, pliki As Object, plik As Object
Dim folder As Object, r&

Set ob = CreateObject("Scripting.FilesystemObject")
Set folder = ob.GetFolder(sciezka)
Set pliki = ob.GetFolder(folder).Files

ProgressBar1.Value = 0 'zerujemy pasek
ProgressBar1.Max = 9   'określamy maximum postępu 

With Application
 .ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
 .DisplayAlerts = False
 For Each plik In pliki
  DoEvents 'kluczowy parametr dzięki któremu będziemy widzieć postęp paska
  If Mid(LCase(plik), InStrRev(plik, ".") + 1, 3) = "xls" Then
    Workbooks.Open Filename:=(sciezka & plik.Name) 'otwieramy tylko pliki XLS
    ProgressBar1.Value = r 'przekazujemy kolejny parametr
    r = r + 1
    ActiveWorkbook.Close False
    If r = 10 Then GoTo przerwij
  End If
 Next plik
przerwij:
 .ScreenUpdating = True
 .Calculation = xlCalculationAutomatic
 .EnableEvents = True
End With

Set ob = Nothing
Set folder = Nothing
Set pliki = Nothing
End Sub

Taką metodę można zastosować w Excelu, Outlooku, jak i w innych aplikacjach pakietu Office.

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.