Re: Macrogesteuerte Korrektur in Kopfzeile
23.05.2003 13:00:24
PeterG
Hallo urs,ich könnte die eine Teillösung für Excel bieten, wobei ich nicht weiß, was mit oben rechts gemeint ist. Ich bin davon ausgegangen, daß der Kopf in Zelle A1 steht, oben rechts also rechts in A1. Ggfs. mußt du das noch anpassen, es ist auch nicht getestet.
Const Verzeichnis$ = "D:\SST\AU\" ' <----------------- einstellen
Private Sub Korrektur()
Dim K$, K1$, K2$, z%, z1%, Leer$, n%
For n = 1 To 100: Leer = Leer & " ": Next ' <----ggfs. noch länger
K$ = Cells(1, 1): z = InStr(K, "11290")
If z = 0 Then MsgBox "11290 nicht gefunden!": Exit Sub
If Len(K) > z + 4 Then
K1 = Mid(K, 5): z1 = InStr(K1, "-")
If z1 > 0 Then
K2 = "Ae " & Format(CInt(Trim(Mid(K1, z1 + 1))), "00")
Else
K2 = "Ae 00"
End If
Else
K2 = "Ae 00"
End If
Cells(1, 1) = Left(K, z + 4)
Rows("2:2").Select: Selection.Insert Shift:=xlDown
Cells(2, 1) = Left(Leer, z - 1) & K2
End Sub
Sub DateienOeffnen() '<-- mit diesem Makro starten
Dim arrFiles As Variant
Dim intCounter As Integer
Dim strPath As String
Dim bln As Boolean
bln = Application.DisplayStatusBar
Application.DisplayStatusBar = True
strPath = Verzeichnis
arrFiles = FileArray(strPath, "*.xls")
For intCounter = 1 To UBound(arrFiles)
Application.StatusBar = "Öffne Datei " & _
arrFiles(intCounter) & "..."
Workbooks.Open strPath & arrFiles(intCounter)
Call Korrektur
Workbooks(arrFiles(intCounter)).Save
Workbooks(arrFiles(intCounter)).Close
Next intCounter
Application.StatusBar = False
Application.DisplayStatusBar = bln
End Sub
Private Function FileArray(strPath As String, strPattern As String)
Dim arrDateien()
Dim intCounter As Integer
Dim strDatei As String
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strDatei = Dir(strPath & strPattern)
Do While strDatei <> ""
intCounter = intCounter + 1
ReDim Preserve arrDateien(1 To intCounter)
arrDateien(intCounter) = strDatei
strDatei = Dir()
Loop
FileArray = arrDateien
End Function