Check column and delete each row if a cell value = a string or it is empty

[TitoElan]

Hi, I am trying to edit or make some old vba code work.
After copying a Range from one workbook and pasting them into another (and it works) that part of the vba code should check a column and if any cell contains a certain string or is empty, the row should be deleted.
With the empty cells the code are working and deleting the rows. With the strings not. But I dont even understand how it is working.

The variable for searching the strings is the
"KeinProfil =...."
Thats what is not working

With the line " this = UCase(Trim(Selection.Cells(1, 2).Value & Selection.Cells(1, 3).Value))" the code is finding correctly the empty cells. But thats what I dont understand.
The code runs till the end with no errors.

I've been trying to fix it but couldn't find the solution :/

    last = UCase(Trim(Range("B6").Value & Range("C6").Value))
GewichtAnfang = "F6"
LaengeAnfang = "G6"
KeinProfil = "$Gesamtstückzahl$Länge FW-Abschnitt [m]$Nettogewicht FW$Neigung(ja=1):"
KeinProfil = KeinProfil & "$Endstirnplatten (0=gelenkig; 1=biegesteif):$Länge FW-Träger [m]"
KeinProfil = KeinProfil & "$Beanspruchungsgruppe$Eingabe: ja/nein$Satteldach$auslegen+messen"
KeinProfil = KeinProfil & "$nur Montageaufwand, kein Materialpreis$HM28x15, l=100mm$22x175"
KeinProfil = KeinProfil & "$Materialdicke/Umfang$Fl35x25$%"
KeinProfil = KeinProfil & "$"
For i = 6 To 5000
   iRow = i & ":" & i
   Rows(iRow).Select
   this = UCase(Trim(Selection.Cells(1, 2).Value & Selection.Cells(1, 3).Value))
   If InStr(KeinProfil, "$" & this & "$") > 0 Then
      Rows(iRow).Delete
      last = this
      i = i - 1
   Else
      If this = "" Then
         Call Zwischensumme(i, GewichtAnfang, LaengeAnfang)
        'If MsgBox("Jetzt wird gelöscht", vbOKCancel) = vbCancel Then Stop
         Loeschbereich = i & ":5000"
         Rows(Loeschbereich).Delete
         i = 5000
      Else
         If this <> last Then
            Call Zwischensumme(i, GewichtAnfang, LaengeAnfang)
            GewichtAnfang = "F" & i
            LaengeAnfang = "G" & i
           'If MsgBox(last, vbOKCancel) = vbCancel Then Stop
         End If
        last = this
      End If
   End If
Next

 

[Alex Blakenburg]

Can you give us an XL2BB of some of the data ?
In particular show us what you have in columns B & C in rows you think should be picked up for deletion.

 

[TitoElan]

I dont have the addin here but maybe it is enough with a screenshoot.
There for example. If the code finds the string "Materialdicke/Umfang" the row should be deleted. For that case the code has the line:
KeinProfil = KeinProfil & "$Materialdicke/Umfang$Fl35x25$%"

 

[Alex Blakenburg]

Its never going to find it because the code is adding "$" to the beginning and end of it before looking in KeinProfil, so in your example it is going to look for
$Materialdicke/Umfang$ which doesn't exist in KeinProfil.

In the code
this = Materialdicke/Umfang
but the search is:

 If InStr(KeinProfil, "$" & this & "$") > 0 Then

Try changing it to

 If InStr(KeinProfil, this) > 0 Then

 

[TitoElan]

Thanks for your help but it doesnt work. I get no errors with that change but the macro causes excel to not respond. I have to close Excel using the task manager. :/

 

[Alex Blakenburg]

OK I missed that you used UCase on your find string. Instr is case sensitive but you have UCase'd one half but not the other.
You don't need the UCase you are better off changing your If statement to the below.
(This below should work whether you remove the UCase or not)

If InStr(1, KeinProfil, this, vbTextCompare) > 0 Then

 

[TitoElan]

I deleted the "Application.ScreenUpdating = False" to see if the code makes anything and yes. It started and with your suggestion it makes a loop with a circle reference at F6 and G6. Here is the code complete. Maybe it helps.

Dim Title
Dim neueMappe
Dim breit As Range

Sub Materialliste_erzeugen(control As IRibbonControl, pressed As Boolean)
'
' Materialliste_erzeugen Makro

    Application.ScreenUpdating = False
    Title = Application.ActiveWorkbook.Name
    Columns("A:P").Select
    Selection.Copy
    Workbooks.Add
    neueMappe = ActiveWorkbook.Name
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Workbooks(Title).Activate
    Application.CutCopyMode = False
    Selection.Copy
    Workbooks(neueMappe).Activate
    Columns("A:P").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone

    Application.CutCopyMode = False
    Columns("I:I").Select
    Columns("I:I").Cut Destination:=Columns("D:D")
    Columns("L:L").Select
    Selection.Cut Destination:=Columns("I:I")
    Columns("P:P").Select
    Columns("P:P").Cut Destination:=Columns("J:J")
    Range("M1:M3").Select
    Range("M1:M3").Cut Destination:=Range("I1:I3")
    Columns("N:N").Select
    Columns("N:N").Cut Destination:=Columns("K:K")
    Range("O1:O3").Select
    Selection.Cut Destination:=Range("K1:K3")
    Columns("L:P").Select
    Selection.Delete Shift:=xlToLeft
    Range("C1:C3").Select
    Selection.Cut Destination:=Range("D1:D3")
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "Materialliste"
    Columns("A:C").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "G�te"
    Range("D5").Select
    Selection.Copy
    Range("D4").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("E4").Select
    Selection.Copy
    Range("D5").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("E5").Select
    Selection.Copy
    Range("E4").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("D5").Select
    Selection.Copy
    Range("E5").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "Gesamtgewicht"
    Range("F5").Select
    ActiveCell.FormulaR1C1 = "[to]"
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "Gesamtl�ngen"
    Range("G5").Select
    Columns("G:G").EntireColumn.AutoFit
    Range("E5").Select
    Selection.Copy
    Range("G5").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("F1:F3").Select
    Selection.Cut Destination:=Range("G1:G3")
    Range("H1:H3").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("D:G").Select
    Selection.NumberFormat = "0.00"
    Range("A1:A3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("B1:B3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("C1:F3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("G1:H3").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A4:A5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("B4:B5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("C4:C5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("D4:D5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("E4:E5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("F4:F5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Columns("F:F").ColumnWidth = 7.86
    Range("F4:F5").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("G4:G5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("H4:H5").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A6:H5000").Select
    Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("I1").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$4:$5"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = "&D"
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = "&F"
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.787401575)
        .RightMargin = Application.InchesToPoints(0.787401575)
        .TopMargin = Application.InchesToPoints(0.984251969)
        .BottomMargin = Application.InchesToPoints(0.984251969)
        .HeaderMargin = Application.InchesToPoints(0.4921259845)
        .FooterMargin = Application.InchesToPoints(0.4921259845)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 4
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    Columns("A:H").Select
    ActiveSheet.PageSetup.PrintArea = "$A:$H"

    
    last = UCase(Trim(Range("B6").Value & Range("C6").Value))
GewichtAnfang = "F6"
LaengeAnfang = "G6"
KeinProfil = "$Gesamtst�ckzahl$L�nge FW-Abschnitt [m]$Nettogewicht FW$Neigung(ja=1):"
KeinProfil = KeinProfil & "$Endstirnplatten (0=gelenkig; 1=biegesteif):$L�nge FW-Tr�ger [m]"
KeinProfil = KeinProfil & "$Beanspruchungsgruppe$Eingabe: ja/nein$Satteldach$auslegen+messen"
KeinProfil = KeinProfil & "$nur Montageaufwand, kein Materialpreis$HM28x15, l=100mm$22x175"
KeinProfil = KeinProfil & "$Materialdicke/Umfang$Fl35x25$%"
KeinProfil = KeinProfil & "$"
For i = 6 To 5000
   iRow = i & ":" & i
   Rows(iRow).Select
   this = Trim(Selection.Cells(1, 2).Value & Selection.Cells(1, 3).Value)
   If InStr(1, KeinProfil, this, vbTextCompare) > 0 Then
      Rows(iRow).Delete
      last = this
      i = i - 1
   Else
      If this = "" Then
         Call Zwischensumme(i, GewichtAnfang, LaengeAnfang)
        'If MsgBox("Jetzt wird gel�scht", vbOKCancel) = vbCancel Then Stop
         Loeschbereich = i & ":5000"
         Rows(Loeschbereich).Delete
         i = 5000
      Else
         If this <> last Then
            Call Zwischensumme(i, GewichtAnfang, LaengeAnfang)
            GewichtAnfang = "F" & i
            LaengeAnfang = "G" & i
           'If MsgBox(last, vbOKCancel) = vbCancel Then Stop
         End If
        last = this
      End If
   End If
Next

    
    Range("I1").Select

    Application.ScreenUpdating = True

    
    MsgBox "Materialliste erstellt", Title:="Materialliste"
    
End Sub


Sub Zwischensumme(i, ByVal GewichtAnfang As String, ByVal LaengeAnfang As String)
          Selection.Insert (xlDown)
          Selection.Insert (xlDown)
          SummeGewicht = "F" & i
          SummeLaenge = "G" & i
          GewichtEnde = "F" & i - 1
          LaengeEnde = "G" & i - 1
          Range(SummeGewicht).Formula = "=SUM(" & GewichtAnfang & ":" & GewichtEnde & ")"
          Range(SummeGewicht).Interior.ColorIndex = 20
          Range(SummeGewicht).Offset(0, -4).Value = "Summe"
          Range(SummeGewicht).Offset(0, -4).Font.Bold = True
          Range(SummeGewicht).Offset(0, -4).Interior.ColorIndex = 20
          Range(SummeLaenge).Formula = "=SUM(" & LaengeAnfang & ":" & LaengeEnde & ")"
          Range(SummeLaenge).Interior.ColorIndex = 20
          i = i + 2
          
    Columns("A:A").Columns.AutoFit
    Columns("F:F").Columns.AutoFit
    Columns("K:K").Columns.AutoFit
    Columns("D:D").Columns.AutoFit
    Columns("H:H").Columns.AutoFit
          
         
End Sub

 

[Alex Blakenburg]

Can I just confirm that you are ok now ?

Assuming the code is working the next step is to remove all the references to Activate and Select. They make the code harder to follow and also make it run slow.
eg everywhere you have something like this:

    Columns("I:I").Select
    Columns("I:I").Cut Destination:=Columns("D:D")
    Columns("L:L").Select
    Selection.Cut Destination:=Columns("I:I")

Remove the "select" reference and effectively oin the 2 lines:

    Columns("I:I").Cut Destination:=Columns("D:D")
    Columns("L:L").Cut Destination:=Columns("I:I")

 

[TitoElan]

Can I just confirm that you are ok now ?

Assuming the code is working the next step is to remove all the references to Activate and Select. They make the code harder to follow and also make it run slow.
eg everywhere you have something like this:

    Columns("I:I").Select
    Columns("I:I").Cut Destination:=Columns("D:D")
    Columns("L:L").Select
    Selection.Cut Destination:=Columns("I:I")

Remove the "select" reference and effectively oin the 2 lines:

    Columns("I:I").Cut Destination:=Columns("D:D")
    Columns("L:L").Cut Destination:=Columns("I:I")

No, what I mean is that the code is not working with the line

        If InStr(1, KeinProfil, this, vbTextCompare) > 0 Then

Till some point yes but then excel doesnt respond anymore before the macro runs to the end and I have to close excel with the task manager.

 

[Alex Blakenburg]

This looks like a very dangerous piece of code to me. What are you trying to do with this ?

      If this = "" Then
         Call Zwischensumme(i, GewichtAnfang, LaengeAnfang)
        'If MsgBox("Jetzt wird gel�scht", vbOKCancel) = vbCancel Then Stop
         Loeschbereich = i & ":5000"
         Rows(Loeschbereich).Delete
         i = 5000