Excel Makro Spalte löschen mit best. Text

Question

Hallo zusammen,
ich habe da ein kleines Problem. Ich habe ein Excel-File übernehmen können, dass ein sehr langes Makro enthält und das auch soweit Super funktioniert.
Verschiedene Excel-Files werden da in einem neuen File zusammen geführt. Bevor das passiert. Soll in den einzelnen Files Spalten gelöscht werden, in denen das Wort "AgroDil Remark" in einer Zelle enthalten ist. Soweit so gut.
Das funktioniert auch bestens, solange in den einzelnen Files dieses "AgroDil Remark" vorhanden ist. Gibt es aber Files, in denen diesen Namen nicht vorkommt, löscht das Makro einfach die letzte Spalte mit Text. Diese Daten fehlt dann natürlich im neuen File.
Ich hoffe ich habe das einigermassen verständlich erklärt und es kann mir da jemand von euch Profis helfe und mir sagen wie man das Makro anpassen kann, dass das nicht mehr passiert?

Besten Dank schon jetzt und Gruss aus der Schweiz
Marcus

Das Makro sieht so aus:

 '----------------------------------------------------------------------
    '... wenn "AgroDil Remark" vorhanden wird zuerst diese Spalte gelöscht!
      
    Range("G6").Select
    intZähler = 0
    For intZähler = 1 To 10 '= max. Anzahl Spalten!
        If ActiveCell.Value = "AgroDil Remark" Then
            Columns(ActiveCell.Column).Select
            Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(intSourceEndzeile, ActiveCell.Column)).Select
            Selection.Delete Shift:=xlToLeft
            Exit For
        Else
            ActiveCell.Offset(0, 1).Select
        End If
    Next

Answer 1

Hallo Marcus,

wenn du nur diesen Codeteil laufen lässt, wirst du feststellen, dass er keine Spalte löscht, wenn das gesuchte Wort nicht vorhanden ist.

Schau mal nach, ob noch an anderer Stelle im Code etwas gelöscht wird oder poste einfach mal den ganzen Code.

Gruß

M.O.

Answer 2

Hallo M.O.
vielen Dank für Deine Antwort. Ja, so was in der Art habe ich mir schon gedacht..... 
Da ich absolut kein Profi bin in Sachen Makro, sehe ich, oder richtigerweise gesagt, übersehe ich die passende Zeile.
Das Makro dass da hinterlegt ist, ist doch relativ gross. Trotzdem bin ich jetzt mal so tollkühn und schmeisse es 1:1 hier rein. Vielleicht findest du ja beim schnellen überfliegen gleich den Fehler.
Vielen Dank und Gruss
Marcus

Option Explicit

Public varKW
Public strSourceFile As String, strTargetFile As String
Public intTargetStartzeile As Integer
Public intSourceStartzeile As Integer, intSourceEndzeile As Integer
Public strModulname As String, intPosModulname As Integer
Public intZähler As Integer
Public intSpaltenZähler As Integer
Public strFileAuswahl As String
Public intFileNumber As Integer
Public intFileCount As Integer
Public intFileZähler As Integer

'FileSystemObject aktivieren ...
'Verweis = "Microsoft Scripting Runtime"
'aktivieren über: Extras > Verweise > ...

Public fso As FileSystemObject
Public vrz As Folder
Public fle As File
Public Const varFolders = "O:\R&T 43\_Fungicide Profiling\Logistik AIRIM\Greenhouse Reports\Screening Operation\TempFiles\"

Sub SteuerungFileImport()

'File im Ordner löschen
    Call WegDamit
'Dateiname des "Greenhouse Reports" ...
    strTargetFile = ActiveWorkbook.Name
'Startzelle für Datenimport ermitteln ...
    Call GetStartpunkt
'Kalenderwoche für den Datenimport bestimmen ...
    Call GetKW
'alle zu importierenden Dateien auswählen ...
    Call GetAllKWFiles
    
End Sub

Sub WegDamit()
Dim backupDir
backupDir = "O:\R&T 43\_Fungicide Profiling\Logistik AIRIM\Greenhouse Reports\Screening Operation\TempFiles\"
On Error Resume Next
Kill (backupDir & "\*.xls")

End Sub

Sub GetKW()
    varKW = InputBox("Welche KW hätten's gern?")
End Sub

Sub GetStartpunkt()
Range("A10").Select
    intTargetStartzeile = 0
    intTargetStartzeile = ActiveSheet.Range("A:A").Find("", after:=ActiveCell).Row
Range("A" & intTargetStartzeile).Select
End Sub

Sub GetAllKWFiles()
'Objektvariable für den Datei-Auswahl-Öffnen-Dialog ...
Dim objFileDialog As FileDialog
'Voreinstellung für alle anzuzeigenden Dateien ...
Dim strFileFilter As String
'Hilfsvariable für die Dateiauswahl ...
Dim varItems

'Dateifilter für den Datei-Auswahl-Öffnen-Dialog definieren ...
strFileFilter = "O:\R&T 43\_Fungicide Profiling\Logistik AIRIM\Greenhouse Reports\Screening Operation\*" & varKW & "*.xls"
'FileDialog Objektvariable definieren ...
Set objFileDialog = Application.FileDialog(msoFileDialogFilePicker)

'mit der Objekt-Umgebungsvariable alle Zuweisungen vornehmen ...
With objFileDialog
    .Title = "Dateiauswahl ..."
    .ButtonName = "importieren ..."
    .InitialFileName = strFileFilter
    .AllowMultiSelect = True
    'FileDialog anzeigen (alle ausgewählten Dateien öffnen) ...
    If .Show = True Then
        intFileCount = 0
        For Each varItems In .SelectedItems
            strFileAuswahl = varItems
            Workbooks.Open strFileAuswahl
            strSourceFile = ActiveWorkbook.Name
            intFileCount = intFileCount + 1
            '---
            Call CheckFileNumbers
            '---
        Next
    End If

End With

Answer 3

Call GetImportData

'am Schluss immer Objektvariablen löschen mit:
Set objFileDialog = Nothing

End Sub

Sub CheckFileNumbers()

Range("A5").Select

intSourceEndzeile = ActiveSheet.UsedRange.Rows.Count - 1
For intZähler = 1 To intSourceEndzeile
    ActiveCell.Offset(1, 0).Select
    If ActiveCell.Value > 199 Then
        intSourceStartzeile = ActiveCell.Row
        intFileNumber = ActiveCell.Value
        Exit For
    End If
Next

'allfällige Meldungen unterdrücken ...
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "O:\R&T 43\_Fungicide Profiling\Logistik AIRIM\Greenhouse Reports\Screening Operation\TempFiles\" & intFileNumber & ".xls"
ActiveWorkbook.Close
'Windows(strSourceFile).Activate
'ActiveWorkbook.Close
Application.DisplayAlerts = True

End Sub

Sub GetImportData()

'Objektvariable für das FileSystemObjekt definieren:
Set fso = New FileSystemObject
Set vrz = fso.GetFolder(varFolders)
intFileZähler = 0
    
ChDir varFolders
For Each fle In vrz.Files
    Workbooks.Open fle.Name
    strSourceFile = ActiveWorkbook.Name
    
    intFileZähler = intFileZähler + 1
    
    'Startposition im SourceFile ...
    Range("A5").Select
    intSourceEndzeile = ActiveSheet.UsedRange.Rows.Count - 1
    For intZähler = 1 To intSourceEndzeile
        ActiveCell.Offset(1, 0).Select
        If ActiveCell.Value > 199 Then
            intSourceStartzeile = ActiveCell.Row
            intFileNumber = ActiveCell.Value
            Exit For
        End If
    Next
    
    'Datenimport 1. Bereich markieren ...
    Range("A" & intSourceStartzeile & ":F" & intSourceEndzeile).Select
    'Markierter Bereich kopieren ...
    Selection.Copy
    'Wechsel zu Zieldatei ...
    Windows(strTargetFile).Activate
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    Application.CutCopyMode = False
    
    'Wechsel wieder zu Quelldatei ...
    Windows(strSourceFile).Activate
    '... Zeile 5 und 6 Zellen verbinden aufheben!
    Rows("5:6").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.UnMerge
    Range("G6").Select
    
    '------------------------------------------------
    '... nun noch die vorhandenen Spalten zählen ...
    intSpaltenZähler = 0
    Range("G6").Select
    For intZähler = 1 To 10 '= max. Anzahl Spalten!
        If ActiveCell.Value <> "" Then
            intSpaltenZähler = intSpaltenZähler + 1
            ActiveCell.Offset(0, 1).Select
        Else
            Exit For
        End If
    Next
    
    '----------------------------------------------------------------------
    '... wenn "AgroDil Remark" vorhanden wird zuerst diese Spalte gelöscht!
      
    Range("G6").Select
    intZähler = 0
    For intZähler = 1 To 10 '= max. Anzahl Spalten!
        If ActiveCell.Value = "AgroDil Remark" Then
            Columns(ActiveCell.Column).Select
            Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(intSourceEndzeile, ActiveCell.Column)).Select
            Selection.Delete Shift:=xlToLeft
            Exit For
        Else
            ActiveCell.Offset(0, 1).Select
        End If
    Next
    
    '---------------------------------------------------------------------
    'Spaltentitel kopieren ...
    'Wechsel wieder zu Quelldatei ...
    Windows(strSourceFile).Activate
    Range("G5").Select
    strModulname = ActiveCell.Value
    intPosModulname = InStr(1, strModulname, "_")
    strModulname = Mid(strModulname, intPosModulname + 1, Len(strModulname) - intPosModulname)
    'Wechsel zu Zieldatei ...
    Windows(strTargetFile).Activate
    If intFileZähler = 1 Then
        Range(Cells(9, 7), Cells(9, 7)).Select
    Else
        Range(Cells(9, 7 + ((intFileZähler - 1) * 9)), Cells(9, 7 + ((intFileZähler - 1) * 9))).Select
    End If

    'Range("G9").Select
    ActiveCell.Value = strModulname
    

Range(ActiveCell, ActiveCell(1, 9)).Select
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .MergeCells = True
End With
    
    
    
    
    
    
    
    'Wechsel wieder zu Quelldatei ...
    Windows(strSourceFile).Activate
    Range(Cells(6, 7), Cells(6, 7 + (intSpaltenZähler - 2))).Select
    Selection.Copy
    'Wechsel zu Zieldatei ...
    Windows(strTargetFile).Activate
    If intFileZähler = 1 Then
        Range(Cells(10, 7), Cells(10, 7)).Select
    Else
        Range(Cells(10, 7 + ((intFileZähler - 1) * 9)), Cells(10, 7 + ((intFileZähler - 1) * 9) + (intSpaltenZähler - 1))).Select
    End If
    'Cells(10, 7).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    Application.CutCopyMode = False
    
    '-------------------------------------
    'Datenimport 2. Bereich markieren ...
    'Wechsel wieder zu Quelldatei ...
    Windows(strSourceFile).Activate
    Range(Cells(intSourceStartzeile, 7), Cells(intSourceEndzeile, 7 + (intSpaltenZähler - 2))).Select
    '
    'Markierter Bereich kopieren ...
    Selection.Copy
    'Wechsel zu Zieldatei ...
    Windows(strTargetFile).Activate
    If intFileZähler = 1 Then
        Range(Cells(intTargetStartzeile, 7), Cells(intTargetStartzeile, 7)).Select
    Else
        Range(Cells(intTargetStartzeile, 7 + ((intFileZähler - 1) * 9)), Cells(intTargetStartzeile, 7 + ((intFileZähler - 1) * 9))).Select
    End If
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Windows(strSourceFile).Activate
'allfällige Meldungen unterdrücken ...
Application.DisplayAlerts = False
ActiveWorkbook.Close
'Windows(strSourceFile).Activate
'ActiveWorkbook.Close
Application.DisplayAlerts = True
    
   
    GetStartpunkt
    
Next

End Sub

Answer 4

Hallo Marcus,

ich habe mir den Code mal angesehen, konnte aber nichts entdecken, was das von dir geschilderte Problem verursachen könnte (außer dass viel mit Activate und Select gearbeitet wird). Ich konnte den Code natürlich nicht ausprobieren, was ganz nützlich wäre, da ja einige Dateien geöffnet und bearbeitet werden. Tatsächlich wird ja nur in dem von dir in der Frage geposteten Codeteil etwas aus einem Arbeitsblatt gelöscht.

Tritt der Fehler immer auf, wenn in einer Datei der gesuchte Begriff nicht vorhanden ist (z.B. auch dann wenn  dieser in der 1. geöffneten Datei nicht vorhanden ist)? Ist der Fehler schon immer aufgetaucht?

Du könntest höchstens mal versuchen, das Makro GetImportData wie folgt zu ergänzen:

Windows(strSourceFile).Activate
 Range("G6").Select
    intZähler = 0
    For intZähler = 1 To 10 '= max. Anzahl Spalten!
        If ActiveCell.Value = "AgroDil Remark" Then
            Columns(ActiveCell.Column).Select
            Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(intSourceEndzeile, ActiveCell.Column)).Select
            Selection.Delete Shift:=xlToLeft
            Exit For
        Else
            ActiveCell.Offset(0, 1).Select
        End If
    Next

Gruß

M.O.

Answer 5

Hallo M.O.
vielen Dank für Deine Bemühungen, ich werde das auch noch testen.
Wir, mein Arbeitskollege und ich, haben noch ein bisschen an den Daten "rumgeschraubt" und haben 3 Veränderungen gemacht und jetzt klappt es......... einigermasen.

Range(Cells(6, 7), Cells(6, 7 + (intSpaltenZähler))).Select 'intSpaltenZähler - 2

Range(Cells(10, 7 + ((intFileZähler - 1) * 9)), Cells(10, 7 + ((intFileZähler - 1) * 9) + (intSpaltenZähler))).Select 'intSpaltenZähler - 1

Range(Cells(intSourceStartzeile, 7), Cells(intSourceEndzeile, 7 + (intSpaltenZähler))).Select 'intSpaltenZähler - 2

Bei diesen 3 Zeilen haben wir den intSpaltZähler von -2 in der ersten Zeile, -1 in der zweiten Zeile und wieder -2 in der dritten Zeile einfach leer gelassen.
Er macht zwar jetzt beim Einfügen der kopierten Felder ein paar komische Sachen, die dann aber vom nächsten Einfügen wieder überschrieben werden und somit nicht ins Gewicht fallen.
Dann habe ich in allen Zeilen ein -1 eingefügt und nun scheint es zu klappen. Mit dem -2 muss er wohl eben eine Spalte zuviel abgeschnitten haben.

Also das Problem ist schon mal gelöst. Vielen Dank für die Hilfe und ich wünsche Dir einen schönen Tag
Marcus