Bitte um Hilfe, aus vielen Makros eins zu machen
19.05.2014 17:53:33
Christian
würdet ihr mir bitte helfen, dass der gesamte nachfolgende Code zukünftig mit drücken von Strg + i ausgeführt wird, anstatt dass ich wie bislang das Makro Hyperlinks auflösen selbst starten muss?
Ich habe vor allem Probleme damit, wie ich die Bezüge auf die Tabellenblätter nun setzen muss, ich hab leider kaum Ahnung davon, das sind alles Makros die die freundlichen Kollegen hier erstellt haben.
Wenn ihr gerade dabei seid, währet ihr so nett und sorgt dafür, dass die MessageBox im Makro Hyperlinks auflösen nicht mehr erscheint und das Makro ohne MessageBox ausgeführt wird?
Außerdem steht ja im Makro1 ebenfalls eine MessageBox, in die ich einen Text eingebe, der dann in bestimmten Zeilen in Tabelle4 Spalte B einfügt wird. Ist es denn möglich, dass das Makro noch in denselben Zeilen, jedoch in Spalte E folgende Formel einfügt? natürlich an die jeweilige Zeile angepasst:
=WENN(D1="";"";DATWERT(TEIL(D1;FINDEN(" ";D1)+1;FINDEN(",";D1)-FINDEN(" ";D1)-1) &"."&WECHSELN(WECHSELN(WECHSELN(WECHSELN(LINKS(GLÄTTEN(LINKS(D1;3));3);"ct";"kt");"ar";"är");"ec"; "ez");"y";"i")&"."&TEIL(D1;FINDEN(",";D1)+2;4)))
Hier dann noch die besagten Makros
einmal in Tabelle1 folgender Code
Sub Hyperlinks_aufloesen()
Dim Zelle As Range, wks As Worksheet
Dim strAdr As String, strPath As String
Dim strOrd As String, AnzOrd As Integer, intPos, intCount As Integer
If MsgBox("Adresse der Hyperlinks in Spalte A in Spalte C eintragen und Hyperlinks löschen?" _
, _
_
vbQuestion + vbOKCancel, "Hyperlinks auflösen") = vbCancel Then Exit Sub
Set wks = ActiveSheet
strPath = ActiveWorkbook.Path
Application.ScreenUpdating = False
With wks
For Each Zelle In .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
With Zelle
If Zelle.Hyperlinks.Count > 0 Then
strAdr = Zelle.Hyperlinks(1).Address
If LCase(Left(strAdr, 4)) = "http" Then
'do nothing - Internet-Link
ElseIf Mid(strAdr, 2, 2) = ":\" Then
'do nothing - Link mit vollständiger Pfadangabe
ElseIf Left(strAdr, 2) = "\\" Then
'do nothing - Link mit Serveradresse - nicht getestet
ElseIf LCase(Left(strAdr, 3)) = "..\" Then
'relative Pfadangabe im Hyperlink
AnzOrd = (Len(strAdr) - Len(VBA.Replace(strAdr, "..\", ""))) / 3
intCount = 0
For intPos = Len(strPath) To 1 Step -1
strOrd = Left(strPath, intPos)
If Mid(strPath, intPos, 1) = "\" Then
intCount = intCount + 1
End If
If intCount = AnzOrd Then Exit For
Next
strAdr = strOrd & VBA.Replace(strAdr, "..\", "")
Else
'Link in Unterverzeichnis des Verzeichnisses der aktiven Datei
strAdr = strPath & "\" & strAdr
End If
Zelle.Offset(0, 2).Value = strAdr
Zelle.Hyperlinks(1).Delete
End If
End With
Next
End With
Application.ScreenUpdating = False
End Sub
und in Modul 2 folgenden Code
Sub BilderRaus()
Worksheets("Tabelle1").Shapes.SelectAll
Selection.Delete
End Sub
Sub Makro1()
' Makro1 Makro
' Tastenkombination: Strg+i
Dim lngletzte As Long
Dim lngLetzte2 As Long
Dim lngIndex As Long
Dim vntArray As Variant
Dim strText As String
BilderRaus
With ActiveWorkbook.Worksheets("Tabelle1")
.Range("A:A,C:D").Delete Shift:=xlToLeft
With .Columns("A:A")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
lngletzte = .Cells.Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If Application.CountA(Worksheets("Tabelle4").Cells) = 0 Then
lngLetzte2 = 1
Else
lngLetzte2 = Worksheets("Tabelle4").Cells.Find(What:="*", _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
.Range(.Cells(1, 1), .Cells(lngletzte, 1)).Copy _
Worksheets("Tabelle4").Cells(lngLetzte2 + 1, 1)
.Columns(1).Clear
End With
With ActiveWorkbook.Worksheets("Tabelle4")
With .Range(.Cells(lngLetzte2 + 1, 2), _
.Cells(.Cells(.Cells.Rows.Count, 1).End(xlUp).Row, 2)).Font
.Name = "Calibri"
.Size = 11
End With
strText = InputBox("Text für Spalte B:", "Eingabe", "Hier der Text")
If Not strText = vbNullString Then
.Range(.Cells(lngLetzte2 + 1, 2), _
.Cells(.Cells(.Cells.Rows.Count, 1).End(xlUp).Row, 2)) = strText
End If
lngLetzte2 = .Cells.Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
.Range(.Cells(1, 5), .Cells(lngLetzte2, 1)).Sort Key1:=.Range("A1:E1"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Columns("A:A").EntireColumn.AutoFit
.Columns("B:B").EntireColumn.AutoFit
End With
HyperlinkAdressaenderung
End Sub
Sub HyperlinkAdressaenderung()
Dim rngZelle As Range
With Worksheets("Tabelle4")
For Each rngZelle In .Columns(1).SpecialCells(xlCellTypeConstants)
If rngZelle.Hyperlinks.Count > 0 Then
rngZelle.Hyperlinks(1).Address = _
Application.Substitute(rngZelle.Hyperlinks(1).Address, _
"http://www", "https://pro-labs")
End If
Next rngZelle
End With
End Sub