AW: Zelle auffüllen über mehrere Blätter
16.08.2018 19:06:46
Sepp
Hallo Sven,
dan probier mal.
Modul Modul4
Option Explicit
Sub sven()
Dim varValue As Variant
Dim lngWS As Long, lngIndex As Long, lngLast As Long, lngCol As Long
On Error GoTo ErrorHandler
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For lngWS = 1 To 32
With ThisWorkbook.Sheets(lngWS)
For lngCol = 1 To 19 Step 6
lngLast = Application.Max(2, .Cells(.Rows.Count, lngCol).End(xlUp).Row)
If Application.CountA(.Range(.Cells(2, lngCol), .Cells(lngLast, lngCol))) > 0 Then
varValue = .Range(.Cells(2, lngCol), .Cells(lngLast, lngCol))
For lngIndex = 1 To Ubound(varValue, 1)
If UCase(varValue(lngIndex, 1)) Like "[A-Z][A-Z]*" Then
If IsNumeric(Mid(varValue(lngIndex, 1), 3)) Then
varValue(lngIndex, 1) = Left(varValue(lngIndex, 1), 2) & _
Format(Mid(varValue(lngIndex, 1), 3), "0000")
End If
End If
Next
.Range(.Cells(2, lngCol), .Cells(lngLast, lngCol)) = varValue
End If
Next
End With
Next
ErrorHandler:
If Err.Number <> 0 Then
MsgBox "Fehler in Modul4" & vbLf & vbLf & "Prozedur:" & vbTab & "sven" & vbLf & _
"Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
Err.Clear
End If
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0