Hallo! Dann probiere es mal so. Gib bei der Abfrage die gewünschten Spalten mit , getrennt ein. Die werden dann Durchlaufen. VG
Option Explicit
Sub BWTest()
Dim ende
Dim eing As Integer
Dim eing2 As Integer
Dim s As Integer
Dim spalten
Dim durchlauf
Dim anzahl As Long
Dim k As Long
Dim y As Long
Dim Waehrung
Application.ScreenUpdating = False
ende = ThisWorkbook.Sheets("SAPBW_DOWNLOAD").Range("b12000000").End(xlUp).Row
'eing = InputBox("Suchspalte")
'eing2 = InputBox("Ausgabe Zelle")
spalten = InputBox("Ausgabe Zelle, Zeilen bitte mit , getrennt eingeben", "Spaltenauswahl")
anzahl = UBound(Split(spalten, ","))
For durchlauf = 0 To anzahl
If IsNumeric(Split(spalten, ",")(durchlauf)) Then
eing2 = Split(spalten, ",")(durchlauf)
For k = 96 To ende
s = Cells(k, Columns.Count).End(xlToLeft).Column
For y = 9 To eing2 - 1
If Cells(k, y).Value = 0 Then
Cells(k, y).Value = ""
End If
Next y
s = Cells(k, Columns.Count).End(xlToLeft).Column
If s = 1 Then
Rows(k).Delete
Else
Waehrung = CustomFormatText(ThisWorkbook.Sheets("SAPBW_DOWNLOAD").Cells(k, s))
If Waehrung <> "*" And Waehrung <> "" Then
ThisWorkbook.Sheets("SAPBW_DOWNLOAD").Cells(k, eing2).Value = Waehrung
End If
End If
Next k
End If
Next durchlauf
Application.ScreenUpdating = True
End Sub
Function CustomFormatText(Cell) As String
Dim i As Long
Dim x As String
Dim CustomFormatString As String
Dim FirstQuote As Boolean
Dim SecondQuote As Boolean
FirstQuote = False
SecondQuote = False
CustomFormatString = Cell.NumberFormat
If Right(CustomFormatString, 1) = "$" Then
CustomFormatText = "$"
GoTo TheEnd
End If
For i = 1 To Len(CustomFormatString)
x = Mid$(CustomFormatString, i, 1)
' Find the first quote sign in the custom format
If FirstQuote = False Then
If Asc(x) = 34 Then
If x = "$" Then
CustomFormatText = "$"
GoTo TheEnd
End If
FirstQuote = True
GoTo GetNextCharacter
End If
End If
' Find the second quote sign in the custom format
If FirstQuote = True Then
If Asc(x) = 34 Then
SecondQuote = True
GoTo TheEnd
End If
End If
' Write out the characters between the first and second quote
If FirstQuote = True And SecondQuote = False Then
CustomFormatText = CustomFormatText + x
End If
GetNextCharacter:
Next i
TheEnd:
End Function
|