VBA Tools

Dla kilku tysięcy wierszy wykonanie poniższej transpozycji formułą jest niewykonalne, Tabela przestawna też nie da oczekiwanego efektu. Rozwiązaniem jest użycie kodu VBA.

Dla utrudnienia przyjmijmy iż nasze dane mają być exportowane nie w osobnym arkuszu ale do pliku CSV.

Poniżej układ jaki posiadamy (lewa strona) oraz jaki chcemy osiągnąć (prawa strona):

Dalej przedstawiam kod jakim można dokonać transpozycji:

Option Explicit

Sub run_this_procedure()
'MVP OShon from VBATools.pl
Const file$ = "c:\temp\plik.csv" '<- change this path
Const kwant$ = ";"
Dim f#: f = FreeFile()
Dim x&, max_row&: max_row = Cells(Rows.Count, "a").End(xlUp).Row
Dim pobrany$

Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Open file For Output As #f
For x = 2 To max_row
 If Cells(x, 1) = Cells(x + 1, 1) Then
   pobrany = pobrany & Cells(x, 2) & kwant
 Else
   pobrany = pobrany & Cells(x, 2) & kwant
   Print #f, Cells(x, 1) & kwant & pobrany
   pobrany = ""
 End If
Next x
Close #f
End Sub

Jeśli mamy wiele danych możemy okracić kod paskiem postępu lub elementami wskazującymi progres w pasku stanu Excela.

(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 załączniku prezentuje rozwiązanie – jak dodać obrazki do listy wyboru „listview” o dowolnej wielkości?

W sytuacji gdy menu automatycznie zwijało by swoje pozycje należy przewidzieć/zagwarantować niezbędne miejsce na jego wyświetlenie.

Ten przykład oparty jest na pętli, ale w podobny sposób możesz dodać zdjęcia o dowolnej nazwie, lub dodać je czytając konstrukcję pliku xml.

'MVP OShon from VBATools.pl
Dim scezka$, x&

Private Sub UserForm_Initialize()
scezka = ThisWorkbook.Path
ImageCombo1.Font.Size = 48
Image1.Visible = False

With ImageCombo1.ComboItems
 .Clear
 'możesz nie wyłowywać w pętli, ale jeden po drugim
 For x = 1 To 3 'ilosc elementów
 Image1.Picture = LoadPicture(scezka & "\XL_" & x & ".jpg")
 Call load_to_imageCombo("Nr_" & x, "Rekord " & x, "El_" & x)
 Next x
End With
ImageCombo1.ComboItems.item(1).Selected = True
End Sub

Sub load_to_imageCombo(klucz$, rekord$, zdjecie$)
 ImageList1.ListImages.Add Key:=zdjecie, Picture:=Image1.Picture
 Set ImageCombo1.ImageList = ImageList1
 ImageCombo1.ComboItems.Add Key:=klucz, _
 Text:=rekord, _
 Image:=zdjecie
End Sub

W załączniku przykład.

(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.

Przez ostatnie 2-3 dni był problem dostępu do zasobów VBATools. Nie wykluczone ze przyczyna była awaria ISP u którego usługa ta była opłacona. Podstawą aby tak sądzić był fakt iż po nr IP nasz serwis był dostępny. Nie wchodząc jednak w szczegóły miejmy nadzieje że taka przypadłość była incydentalna.

Pamiętacie może ankietę zorganizowaną przez Franmo, producenta aplikacji Odkurzacz. Pisałem na ten temat w ogłoszeniach na VBATools.

To iż akcja została zakończona mogę spokojnie podpowiedzieć rozwiązanie. Rozwiązanie bez podawania podpowiedzi, ale metody VBA na odszukanie istniejącej strony www.

To iż strona miała zawierać się w przedziale 4rech znaków i było tylko jedno rozwiązanie procedura wyników 4!=256 stron może być obsłużona w następujący sposób.

Option Explicit

Sub szukaj_wersji()
Const domain$ = ".franmo.pl/"
Dim czas As Single: czas = Timer
Dim z1&, z2&, z3&, z4&, q&, str$
Range("a:a").Clear
For z1 = 1 To 4
 For z2 = 1 To 4
 For z3 = 1 To 4
 For z4 = 1 To 4
 str = "http://" & literka(z1 & z2 & z3 & z4) & domain
 If Len(WebExists(str)) > 0 Then
 q = q + 1
 ActiveSheet.Hyperlinks.Add _
 Anchor:=Cells(q, 1), _
 Address:=str: GoTo koniec
 'bo i tak spodziewamy się 1 wyniku
 End If
 Next
 Next
 Next
Next
koniec:
Beep
Debug.Print Timer - czas
Debug.Print "Ilość stron " & q
End Sub

Function literka(wart$) As String
Dim u&, r$
 For u = 1 To Len(wart)
 r = r & LCase(Chr(Mid(wart, u, 1) + 64))
 Next u
literka = r
End Function

Private Function WebExists(strona$) As String
'kontrolka XML z referencji
'Dim objHttp As New MSXML2.ServerXMLHTTP

'lub późne wiązanie
Dim objHttp As Object

On Error GoTo blad:
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
 With objHttp
 .setTimeouts 1000, 1000, 1000, 5000
 .Open "GET", strona, False
 .Send
 WebExists = .responsetext
 End With
blad:
If Err > 0 Then WebExists = ""
Set objHttp = Nothing
End Function

Wynik jest osiągalny po 116 sekundach (zakładając dobry dostęp do docelowego serwera). Metodę można usprawnić prowadzając funkcję opartą na właściwości parent, która będzie zagłębiała się w obrębie jednej pętli na zadeklarowaną ilość.

(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.

Jeden z formowiczów Outlook.pl miał potrzebę podziału wyeksportowanych kontaktów ze zbiorczego pliku VCF wyprodukowanego z programu Roundcube. To iż Outlook z pakietu Office nie potrafi podzielić takiego pliku i wyświetla go jako jeden kontakt, utrudnia jego wykorzystanie… (czytaj dalej …)

Dzisiaj miałem trzy maszyny, na których pojawił sie komunikat: „Object library invalid or contains references to object definitions that could not be found”, który uniemożliwił korzystać z zaprogramowanych narzędzi w MS Office. Co zrobić w takim przypadku opisuje poniżej. (czytaj dalej …)

Od piątku walczyłem z przypadłością związaną z uniemożliwieniem poprawnego kopiowania właściwości obszaru w MS Excel. Objawiało się to brakiem zaznaczenia obszaru (podświetlona ramka) a kończyło się wklejeniem tylko tekstu (bez formatów wypełnienia, treści formuły, kolorów itp..). Jedynym sposobem aby skopiować formułę było przeciągnięcie formuły z wcześniej umieszczonej powyżej. (czytaj dalej …)

Stopniał śnieg i chyba już w tym roku go nie zobaczymy. Przyszedł też czas na to aby odurzyć parę przełożonych na później acz istotnych tematów.

Jednym z nich jest test Visual Studio 2011. Jego pojawienie się na rynku zbiega się z emisją wersji Developer i Customer Preview o którym jakiś czas pisałem. W nim właśnie będzie można odnaleźć nowe szablony dedykowane dla tego systemu. (czytaj dalej …)

Fanmo wypuścił nową wersje odkurzacza – już do pobrania na warunkach ankiety. Dla tych którzy nie spotkali się do tej pory z jego wcześniejszymi wersjami należy się małe wprowadzenie.

Odkurzacz to program, mający na zadanie odchudzenia/odkurzenia naszego systemu operacyjnego ze wszystkich zbędnych plików. (czytaj dalej …)

Jaką funkcję programu Microsoft Outlook lubisz najbardziej i dlaczego? Tak brzmi pytanie konkursowe. Czy nie jest za trywialne, ale bogactwo funkcjonalności tego wyjątkowego klienta pocztowego daje mnóstwo możliwości.

Spośród 10 najciekawszych odpowiedzi producent przekaże ich autorom nagrodę w postaci licencji do programu pracy grupowej w Outlooku CodeTwo Public Folders (na 10 stanowisk każda).

Jako moderator forum Outlook.pl zachęcam do wzięcia udziału. Taka okazja może się więcej nie powtórzyć!

(czytaj dalej …)