ich möchte alle Zahlen kopieren in jeweils ein neues blatt wenn
eine Zahl dann ein Punkt und wieder eine Zahl.
Also 1.1, 1.2, 1.3 in ein Blatt aber 2.1, 2.4 in ein neues Blatt.
Sub Auft()
Dim wks As Worksheet
Dim arr As Variant
Dim i As Integer, y As Integer, iRow As Integer, iRowT As Integer
Dim sTxt As String, sNo As String
Set wks = Worksheets(1)
Call DeleteWks
For iRow = 1 To wks.Cells(Rows.Count, 1).End(xlUp).Row
sTxt = wks.Cells(iRow, 1).Value
If InStr(sTxt, ".") Then
arr = Split(sTxt, ".")
If UBound(arr) = 1 Then
If arr(0) & "." & arr(1) > sNo Then
sNo = arr(0) & "." & arr(1)
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = wks.Cells(iRow - 1, 1).Value
iRowT = 3
Rows(iRowT).Value = wks.Rows(iRow).Value
iRowT = iRowT + 1
ActiveSheet.Range("a1").Value = "Objekt"
ActiveSheet.Range("b1").Value = "TA"
ActiveSheet.Range("c1").Value = "Anzahl"
ActiveSheet.Range("d1").Value = "Bauteilnummer"
ActiveSheet.Range("e1").Value = "Bezeichnung"
ActiveSheet.Range("f1").Value = "Spanne"
ActiveSheet.Range("g1").Value = "EK EP"
ActiveSheet.Range("h1").Value = "EK GP"
ActiveSheet.Range("i1").Value = "VK EP"
ActiveSheet.Range("j1").Value = "VK GP"
Columns("G:J").Select
Selection.NumberFormat = "#,##0.00 €"
Else
Rows(iRowT).Value = wks.Rows(iRow).Value
iRowT = iRowT + 1
End If
End If
End If
Next iRow
ich hoffe es kann mir jemand einen Tip geben wo der Fehler hängt |