Makro hinter Excel-Tabellen
17.09.2013 16:30:51
Pamela
Bereits letzte Woche wurde mir hier in diesem tollen Forum geholfen. Eigentlich ist meine aktuelle Frage eine Ergänzungsfrage zu meinem Post am 13.09.
Dennoch erlaub ich mir, meine Frage hier als neues Post zu eröffnen.
Meine Frage lautet wie folgt:
In einer Excel Arbeitsmappe mit 24 Tabellenblätter hab ich hinter jedes Tabellenblatt folgende Codes (welche ich dank tollster Hilfe hier aus dem Forum zusammenbauen konnte) kopiert:
Public AlterWert As String
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Const Logfilename = "\Archiv\\Aenderungen_log.txt"
Dim User As String
Dim Protokoll As Long
Dim Logfile As String
Dim Zelle As Range
Dim S_Alpha As String ' Variable für den String, der der Spalztennummer entspricht (1=A, 2=B, _
26=Z, 27=AA...
Dim objHyp As Hyperlink, arrEndung, strEnde, strMatch As String
User = UserName()
Logfile = ActiveWorkbook.Path & Logfilename ' Logfile im gleichen Pfad ablegen, wie die _
Excel-Datei.
Open Logfile For Append As #1
' Behandlung der Spalten>Z, da dann mit AA, AB etc. weitergemacht wird.
If Target.Column > 26 Then
S_Alpha = Chr(Asc("A") + (Target.Column \ 26) - 1) & Chr(Asc("A") + (Target.Column Mod 26) _
- 1) ' = div-Operator
Else
S_Alpha = Chr(Asc("A") + Target.Column - 1)
End If
' Chr (Asc("A") + Target.Column - 1) oops, diese Zeile ist wohl überflüssig. Überbleibsel vom _
Testen
' Wurde 1 Zelle geändert (count=1) oder mehrere (Else-Zweig) ?
' Die Print-Anweisung schreibt einfach den dahinter mit & gebildeten Stringg in das Logfile
If Target.Cells.Count = 1 Then
Print #1, Date & ": " & ActiveSheet.Name _
& ": " & S_Alpha & Target.Row & ": " & AlterWert & ":" & Target.Text
Else
For Each Zelle In Target
Print #1, Date & ": " & ActiveSheet.Name _
& ": " & S_Alpha & Zelle.Row & ": " _
& ": " & Zelle.Text
Next Zelle
End If
Close #1
'nun wird für jede Zeile geprüft ob in Spalte "D" ein Hyperlink steht. Wenn ja, dann wird aus _
dem Link die Dateiendung ermittelt
'und in die Spalte "P" geschrieben
arrEndung = Array(".xls", ".xlsx", ".xlsm", ".doc", ".docx", ".docm", _
".dotx", ".pptx", ".ppsm", ".ppsx", ".xltx", ".csv", ".jpg", ".gif", ".pdf", ".ppt", ".pps", " _
.txt") 'anpassen
With ActiveSheet
For Each objHyp In .Hyperlinks
strMatch = objHyp.TextToDisplay
strEnde = Right(strMatch, Len(strMatch) - InStrRev(strMatch, ".") + 1)
If Not IsError(Application.Match(strEnde, arrEndung, 0)) Then
.Cells(objHyp.Range.Row, 16) = strEnde
End If
Next
End With
End Sub
Public Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
On Error Resume Next
AlterWert = Target ' Wert sichern, wenn neue Zelle selektiert wird. Ersatz für ein " _
Before_Change" Ereignis.
End Sub
Mein Problem besteht nun darin, dass mir mein Excel ständig hängenbleibt (Meldung: reagiert nicht mehr) vermutlich weil mein obiger Programmcode in einer Endschlaufe loopt ?
Frage:
kann ich das obige Programm irgendwie so anpassen, dass dieses nicht mehr loopt sondern nur noch solange arbeitet wie auch Datensätze auf dem Tabellenblatt vorhanden sind?
Meine Idee: Zuerst pro Tabellenblatt die Anzahl vorhandenen Datensätze ermitteln und das Programm nur solange in einer Schleife durchlaufen lassen, bis die Anzahl Datensätze durchlaufen ist.
Ich hoffe sehr, man versteht meine Frage und kann mir hier wie schon letzte Woche weiterhelfen.
ich danke euch!
Pamela
Anzeige