Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Prośba o modyfikację makra

CAVIS · Wysłany: 11-01-2007, 12:27 **Prośba o modyfikację makra**

Witam!

W ThisWorkbook wpisany jest następujący kod:

Private Sub Workbook_Open()
Dim i As Long
Dim nazwa As String

For i = 1 To Me.Worksheets.Count
nazwa = Me.Worksheets(i).Name
Me.Worksheets("Arkusz1").Hyperlinks.Add _
Anchor:=Me.Worksheets(1).Cells(i + 1, 1), _
Address:="", _
SubAddress:="'" & nazwa & "'!A1", _
TextToDisplay:=nazwa
Next
With Me.Worksheets("Arkusz1")
.Range(.Cells(i + 1, 1), .Cells(65536, 1)).Delete xlShiftUp
End With
End Sub

Efektem tego makra jest wypisanie wszystkich arkuszy w skoroszycie.

Załącznik (Arkusz11) jest przykładem, jaki efekt chciałabym uzyskać.

Moja prośba o modyfikację, aby wyrazy zaczynające się na literę "P"- w komunie B wpisuje się też hiperłącze do tego arkusza.

Wyrazy zaczynające się na literę "R"- w komunie C wpisuje się też hiperłącze do tego arkusza.

Wyrazy zaczynające się na literę "Z"- w komunie D wpisuje się też hiperłącze do tego arkusza.

Wyrazy, krórych pierwsza litera jest inna niż wcześniej wymienione - w komunie E wpisuje się też hiperłącze do tego arkusza.

Zeszyt11.zip

Pobierz Plik ściągnięto 809 raz(y) 8.05 KB

DarLeg · Wysłany: 11-01-2007, 16:52

Hej

między te dwie linijki

Tajan · **Pomógł:** 5501 razy Posty: 11968

Można to zrobić np. w ten sposób:

Kod:

Private Sub Workbook_Open()
Dim i As Long
Dim nazwa As String
Dim kolumna As String

For i = 1 To Me.Worksheets.Count
nazwa = Me.Worksheets(i).Name
Me.Worksheets("Arkusz1").Hyperlinks.Add _
Anchor:=Me.Worksheets(1).Cells(i + 1, 1), _
Address:="", _
SubAddress:="'" & nazwa & "'!A1", _
TextToDisplay:=nazwa

Select Case UCase(Left(nazwa, 1))
Case "P": kolumna = "B"
Case "R": kolumna = "C"
Case "Z": kolumna = "D"
Case Else: kolumna = "E"
End Select

Me.Worksheets("Arkusz1").Hyperlinks.Add _
Anchor:=Me.Worksheets(1).Cells(i + 1, kolumna), _
Address:="", _
SubAddress:="'" & nazwa & "'!A1", _
TextToDisplay:=nazwa

Next
With Me.Worksheets("Arkusz1")
.Range(.Cells(i + 1, 1), .Cells(65536, 1)).Delete xlShiftUp
End With
End Sub

CAVIS · Wysłany: 12-01-2007, 08:19

Witaj Tajan!

Dziękuję po raz kolejny za pomoc.

Twoje rozwiązanie jest tym, o które mi chodziło. Ma tylko jeden błąd w kodzie poniżej, 1 należy zamienić na 5, gdyż czyszczeniu powinien podlegać cały obszar wpisanych poprzednio danych czyli 5 kolumn.

Next
With Me.Worksheets("Arkusz1")
.Range(.Cells(i + 1, 1), .Cells(65536, 1)).Delete xlShiftUp
End With
End Sub

CAVIS · Wysłany: 12-01-2007, 10:13

Witam ponownie!

Chyba moja poprawka jest w niewłaściwym miejscu, lub powinna być inna zmiana.
Z tym czyszczeniem jest nadal coś nie tak!

Tajan · **Pomógł:** 5501 razy Posty: 11968

Przyznam się, że skupiłem się na problemie o który pytałaś i nie analizowałem poprawności całego makra. Proponuję takie rozwiązanie:

Kod:

Private Sub Workbook_Open()
Dim i As Long
Dim nazwa As String
Dim kolumna As String

With Me.Worksheets("Arkusz1")
.Range("A2").Resize(.UsedRange.Rows.Count - 1, 5).Delete
End With

For i = 1 To Me.Worksheets.Count
nazwa = Me.Worksheets(i).Name
Me.Worksheets("Arkusz1").Hyperlinks.Add _
Anchor:=Me.Worksheets(1).Cells(i + 1, 1), _
Address:="", _
SubAddress:="'" & nazwa & "'!A1", _
TextToDisplay:=nazwa

Select Case UCase(Left(nazwa, 1))
Case "P": kolumna = "B"
Case "R": kolumna = "C"
Case "Z": kolumna = "D"
Case Else: kolumna = "E"
End Select

Me.Worksheets("Arkusz1").Hyperlinks.Add _
Anchor:=Me.Worksheets(1).Cells(i + 1, kolumna), _
Address:="", _
SubAddress:="'" & nazwa & "'!A1", _
TextToDisplay:=nazwa

Next

End Sub

Pozdrawiam

CAVIS · Wysłany: 12-01-2007, 10:56

Witaj Tajan!

Dziękuję. O to mi chodziło.

CAVIS · Wysłany: 12-01-2007, 12:12

Witaj Tajan!

Znalazłam jeszcze jeden błąd w działaniu makra.

Jeżeli arkusz będzie zaczynał się na literę "r" (pisany z małej), to wstawiło mi się w kolumnę odpowiadającą za "Z".
Nie sprawdzałam innych małych liter.

P.S.
Przeprowadziłam testy.
W załączniku wynik.

Zeszyt próbny.zip

Pobierz Plik ściągnięto 738 raz(y) 11.61 KB

Tajan · **Pomógł:** 5501 razy Posty: 11968

Niestety, nie mogę uzyskać takiego efektu. Wynik mam taki, jak w załaczniku. Zresztą, teoretycznie, błąd o którym piszesz nie powinien wystąpić, bo pierwsza litera nazwy arkusza jest zawsze poczas sprawdzania zamieniana na wielką (funkcją UCase).
Dostrzegłem jednak jescze jeden błąd w makrze, który mógłby mieć przykre konsekwencje, gdyby Arkusz1 zastał przesunięty na inną pozycję.
Koniecznie popraw kod w następujacy sposób:

Kod:

Private Sub Workbook_Open()
Dim i As Long
Dim nazwa As String
Dim kolumna As String

With Me.Worksheets("Arkusz1")

.Range("A2").Resize(.UsedRange.Rows.Count - 1, 5).Delete

For i = 1 To Me.Worksheets.Count

nazwa = Me.Worksheets(i).Name

.Hyperlinks.Add _
Anchor:=.Cells(i + 1, 1), _
Address:="", _
SubAddress:="'" & nazwa & "'!A1", _
TextToDisplay:=nazwa

Select Case UCase(Left(nazwa, 1))
Case "P": kolumna = "B"
Case "R": kolumna = "C"
Case "Z": kolumna = "D"
Case Else: kolumna = "E"
End Select

.Hyperlinks.Add _
Anchor:=.Cells(i + 1, kolumna), _
Address:="", _
SubAddress:="'" & nazwa & "'!A1", _
TextToDisplay:=nazwa

Next
End With
End Sub

EDIT: Pisałaś o małych literach, a ja teraz dopiero dostrzegłem, że po prostu i wielkie i małe litery trafiają do niewłaściwej kolumny! :-D

Te z "R" i "r" do Z a te z "Z" i "z" do R.
Nie wiem jak ma być, bo pisałaś wcześniej:

Cytat:

Wyrazy zaczynające się na literę "R"- w komunie C wpisuje się też hiperłącze do tego arkusza.
Wyrazy zaczynające się na literę "Z"- w komunie D wpisuje się też hiperłącze do tego arkusza.

Albo skoryguj arkusz, albo zamień litery w odpowiednich sekcjach instrukcji Select Case.[/code]

efekt.gif

Plik ściągnięto 7595 raz(y) 3.47 KB

CAVIS · Wysłany: 15-01-2007, 08:46

Witaj Tajan!

Dopiero teraz zauważyłam moją pomyłkę. Masz rację.
Przepraszam, że czepiałam się o błąd w makrze.
Pisząc prośbę o pomoc, nagłówki kolumn były ustawione w innej kolejności.

Jeszcze raz dziękuję. :-)