Office: (Office 2016) VBA- Projektname aus Importdatei kopieren und in anderes Tabellenblatt einfügen

Hallo zusammen,

ich habe heute schon ein paar Stunden an meiner Excel Tabelle gebastelt, aber nun brauch ich doch bitte eure Hilfe:

Ich habe zwei Tabellenblätter (Overview & Import). In Import wird eine systemgenerierte Liste als Werte eingefügt.
Overview hat die folgenden Buttons:

1. Vorbereitung der Importtabelle (Merge aus, Spalten löschen, etc.) -> funktioniert
2. Import Daten (Spalte A bis G wird aus Import übernommen) -> funktioniert
3. Alle Daten aus Overview löschen -> funktioniert
4. Projektname importieren (fixe Zelle in Import wird den importierten Zeilen in Overview zugeordnet) -> funktioniert teilweise, aber nicht wie ich es will

Mein Problem ist, dass ich den Import für 3. für mehrere Projekte durchführen muss und alles schön untereinander in Overview angezeigt werden soll.
Der Import der Projektnamen funktioniert beim ersten mal gut.
Wenn ich jetzt aber meinen Projektnamenimport zum 2-ten, 3-ten bzw. x-ten mal starte, überschreibt er mir alle Daten in Spalte H.

Wo ist da der Wurm drin?

Vielen Dank für eure Hilfe!

Gruß,
Florian

Code:

Private Sub cmdProjectImport_Click()
    Dim Project As String, lastrow1 As Long, i As Long, Col As Range

        lastrow1 = Sheets("Overview").Cells(Rows.Count, 1).End(xlUp).Row
           
      
   For i = 3 To lastrow1
    If Sheets("Overview").Cells(i, 1) Like ("A2*") Then
        With Sheets("Overview")
        lastrow1 = .Cells(Rows.Count, 8).End(xlUp).Row
        If lastrow1 < 2 Then lastrow1 = 2
        End With
        Sheets("Import").Cells(2, 4).Copy Destination:=Sheets("Overview").Cells(i, 8)
        End If
        
    Next i
         
'*********************************************************************
'Automatische Breite
    For Each Col In Sheets("Overview").UsedRange.Columns
    Col.AutoFit
    Next Col
    
'*********************************************************************
'Auto Filter
    If Not ActiveSheet.AutoFilterMode = True Then
    Range("A2:H2").AutoFilter
    End If
    
'*********************************************************************
'Clear Import
    Sheets("Import").Cells.Clear
    
    MsgBox "Project numbers have been transfered." & vbNewLine & "Import sheet cleared."
    
End Sub

 

Hallo,

da ich nicht wirklich erkennen kann, was wo(hin) gespeichert ist, beschreibe ich, was dein Makro macht:

1. In die Variable "lastrow1" wird die letzte Zeilennr. von Spalte A, die Daten enthält, gespeichert.
2. Dann wird mittels Schleifenvariable "i" der Zeilenbereich von Zeile 3 bis zu Zeile "lastrow1" durchlaufen, indem
   • in Spalte A der i.Zeile überprüft wird, ob dort der Wert "A2..." gespeichert ist: falls ja, wird das Folgende ausgeführt (sonst übersprungen):
   • Es wird die letzte Datenzeile der Spalte H ermittelt und in Variable "lastrow1" gespeichert (Anmerkung: Dieser "lastrow1"-Wert beeinflusst NICHT die Schleifenvariable "i" !!!, denn deren Laufintervall wird in der FOR-Zeile festgelegt und kann dann nicht mehr geändert werden!!!)
   • Wird dabei festgestellt, dass "lastrow1"=1, dann wird "lastrow1" auf 2 gesetzt.
   • Im Anschluss an den WITH-Block wird dann Zelle D2 aus Arbeitsblatt "Import" in die Zelle von Zeile "i" und Spalte H des Blattes "Overview" kopiert

Damit ist der Kopiervorgang aus Blatt "Import" einzig und allein von der Schleifenvariable "i" abhängig, die stets von 3 bis zur letzten in Spalte A verwendeten Zeile läuft, womit auch klar ist, dass der Zellbereich ab Zeile 3 der Spalte H immer wieder überschrieben wird bei mehrmaliger Makroausführung (sofern in Spalte A der Wert "A2..." enthalten ist).

Ich vermute, dass das Makro in etwa wie folgt lauten müsste:

Code:

Private Sub cmdProjectImport_Click()
    Dim Project As String, lastRowA As Long, firstEmptyRowH As Long
    Dim i As Long, Col As Range

   With Sheets("Overview")
     lastRowA = .Cells(Rows.Count, 1).End(xlUp).Row
           
     For i = 3 To lastRowA
       If .Cells(i, 1) Like "A2*" Then
          firstEmptyRowH = .Cells(Rows.Count, 8).End(xlUp).Row + 1
          If firstEmptyRowH < 2 Then firstEmptyRowH = 2
          Sheets("Import").Cells(2, 4).Copy Destination:=.Cells(firstEmptyRowH, 8)
       End If
     Next i
     
   End With
'....
'...usw...
End Sub

 

Hallo Anton Exl,

nach deiner Erklärung macht es Sinn, dass mein Code keinen Sinn macht ;)
Hatte schon die Befürchtung, dass meine Erklärung unklar war, aber deine Annahme wie der Code auszusehen hat war absolut richtig!
Der Code funktioniert einwandfrei!

Vielen vielen Dank!!!

Gruß,
Florian

 

Problem mit Zuordnung zwischen Tabellenblättern

Hallo,

ich habe ein weiteres Problem mit meiner Excel.

Folgender Code funktioniert und vergleicht Art.-Nummern zwischen Sheet "Overview" und "Project_Import".
Bei einem Match der Nummern kopiert der Code den zugehörigen Status des Artikels aus dem Import (Spalte K) in Overview (Spalte I)

Wie gesagt der Code läuft und er ordnet auch zu, jedoch habe ich in den Art.-Nummern teilweise Duplikate, weil dort andere Lieferanten hinterlegt sind.

Jetzt kopiert mir der Code aber den Status immer nur 1x zur ersten gefundenen Art.-Nr.

Was muss geändert werden, dass alle Art.-Nr. auch den Status zugeordnet bekommen?

Hoffe ihr könnt mir nochmal weiterhelfen!

Danke!!!

Code:

Sub ProImportStatus()

Dim calcStatus As Long
Dim CelStatus As Range
Dim LastRow As Long
Dim rFoundStatus As Range
Dim LookRange As Range
Dim CelValueStatus As Variant
  
    'Get Last row of data Project_Import, Col B
    LastRow = Sheets("Project_Import").Cells(Rows.Count, 2).End(xlUp).Row
    
    ' Set range to look in
    Set LookRange = Sheets("Project_Import").Range("B1:B" & LastRow)
    
    ' Loop on each value (cellStatus)
    For Each CelStatus In LookRange
        ' Get value to find
        CelValueStatus = CelStatus.Value
        ' Look on Overview
        With Sheets("Overview")
            
            ' Allow not found error
            On Error Resume Next
    
            Set rFoundStatus = .Cells.Find(What:=CelValueStatus, _
                After:=.Cells(4, 1), LookIn:=xlValues, _
                    Lookat:=xlWhole, MatchCase:=False)
         
            ' Reset
            On Error GoTo endo
            
            ' Not found, go next
            If rFoundStatus Is Nothing Then
                GoTo nextCelStatus
            Else
                ' Found. Copy Project_Import, Col K to Overview found Row, Col I
                Sheets("Project_Import").Cells(CelStatus.Row, 11).Copy .Cells(rFoundStatus.Row, 9)
            End If
        End With
        
nextCelStatus:
    Next CelStatus
    
'Reset
    
endo:

    With Application
        .Calculation = calcStatus
        .ScreenUpdating = True
    End With

End Sub

 

Ein weiteres Problem ist aufgetaucht: Beim Import mehrerer Projekte löscht mir der o.g. Code immer den Status aus der ersten Datenzelle in Overview (in diesem Fall (4, 9)).

 

Hallo,

nachfolgend habe ich dein Makro für die mehrmalige Suche nach dem Wert CelValueStatus angepasst.

Das habe ich auch bereits befürchtet bei der ersten Sichtung deines Codes. Das Problem besteht darin, dass du den Suchbereich der Methode "Find" auf das gesamte Arbeitsblatt "Overview" ausgedehnt hast, indem du programmierst ".Cells.Find(…)". Du gibst zwar als Startzelle ".Cells(4,1)" an, sodass die Suche ab der nächste Zelle (das ist Overview!B4) begonnen wird. Hast du aber zB. bei früheren Datenimporten bereits eine Datenkopie nach Zelle Overview!I4 ausgeführt und dieser Wert ist zufällig gleich mit dem jetzigen Suchwert CelValueStatus, so wird jetzt eine neuerliche Kopie in diese Zelle I4 (oder I5 etc.) durchgeführt. Darüber hinaus können noch weitere nicht gewünschte Zufallsfunde auftreten. Der Suchbereich sollte somit so klein wie möglich gehalten werden.
Dabei kommt noch (erschwerend) hinzu: Haben die Methoden Find bzw. FindNext den gesamten Suchbereich durchsucht, beginnen sie wieder bei der ersten Zelle des Suchbereichs (unabhängig davon, was bei After:=… angegeben wurde) zu suchen - im Falle des gesamten Arbeitsblattes wieder bei A1.

Es ist deshalb dringend ratsam, eine Entkoppelung des Suchbereichs und des Kopier-Zielbereichs (= Spalte I von Blatt "Overview") einzubauen. Da ich deine Datenstruktur im Arbeitsblatt "Overview" nicht kenne, konnte ich das nicht bereits einbauen. Ich vermute aber, dass sich der Suchbereich auf 1 Arbeitsblattspalte beschränken lässt.
Aufgrund der Startzelle in ".Cells(4,1)" (=$A$4) vermute ich, dass dies Spalte A sein wird.
Dann müsste die Zeile mit der Find-Methode lauten:
Set rFoundStatus = .Columns("A").Find(What:=CelValueStatus, After:=.Cells(4, 1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
und die Suche würde dann in Zelle A5 (als nächster Zelle im Suchbereich nach A4 statt wie bisher B4) starten.
Ferner müsste die Zeile mit der FindNext-Methode lauten:
Set rFoundStatus = .Columns("A").FindNext(After:=rFoundStatus)

Code:

Sub ProImportStatus()

Dim calcStatus As Long
Dim CelStatus As Range
Dim LastRow As Long
Dim rFoundStatus As Range, FirstFoundAddress As String
Dim LookRange As Range
Dim CelValueStatus As Variant
Dim WsImport As Worksheet, WsOvView As Worksheet

    Set WsImport = Worksheets("Project_Import")
    Set WsOvView = Worksheets("Overview")
    
    With WsImport
      'Get Last row of data Project_Import, Col B
      LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
      ' Set range to look in
      Set LookRange = .Range("B1:B" & LastRow)
    End With
    
    ' Loop on each value (cellStatus)
    For Each CelStatus In LookRange
        ' Get value to find
        CelValueStatus = CelStatus.Value
        ' Look on Overview
        With WsOvView
    
            ' Sucht den Wert CelValueStatus ab der Zelle, die auf Overview!A4 folgt, also ab Zelle Overview!B4
            Set rFoundStatus = .[COLOR="#FF0000"]Cells[/COLOR].Find(What:=CelValueStatus, After:=.[COLOR="#FF0000"]Cells(4, 1)[/COLOR], LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
            If Not rFoundStatus Is Nothing Then
               'Es gab einen ersten Zellfund -> Merke dir die Adresse dieser Zelle:
               FirstFoundAddress = rFoundStatus.Address
               Do
                 ' Found. Copy Project_Import, Col K to Overview found Row, Col I
                 WsImport.Cells(CelStatus.Row, 11).Copy .Cells(rFoundStatus.Row, 9)
                 ' Suche nach der nächsten Zelle im Suchbereich von Blatt "Overview" mit Wert CelValueStatus!
                 ' Da du als Suchbereich alle Zellen (.Cells) des Blattes "Overview" angegeben hast,
                 ' werden auch ALLE Zellen durchsucht. Dadurch kann es zu Konflikten mit nicht gewollten Zufallsfunden kommen!!!
                 ' Es ist daher dringend ratsam, den Suchbereich einzuschränken - zumindest auf einen Bereich, der außerhalb von Spalte I liegt.
                 ' Hat dabei die Methode "Suchbereich.FindNext" das ganze - wegen .Cells - Arbeitsblatt "Overview" durchsucht,
                 ' beginnt sie die Suche wiederum bei der ersten Zelle des Suchbereichs, also bei Overview!A1 (wegen .Cells.FindNext).
                 Set rFoundStatus = .[COLOR="#FF0000"]Cells[/COLOR].FindNext(After:=rFoundStatus)
                 ' Brich die wiederholte Suche dann ab, wenn es sich beim abermaligen Fund um den ersten Zellfund handelt:
               Loop Until rFoundStatus.Address = FirstFoundAddress
            End If
            
        End With
        
    Next CelStatus
    
'Reset
    
endo:

    With Application
        .Calculation = calcStatus
        .ScreenUpdating = True
    End With

End Sub

 

Hola,

zur Info:
https://www.ms-office-forum.net/forum/showthread.php?t=361805

Gruß,
steve1da

 

Jetzt geht gar nichts mehr...Excel hängt sich jetzt auf und muss per Taskmanager gekillt werden...
Die Punkte in rot habe ich auf Columns"A" geändert, da in Overview jeweils zu Spalte A in H und I zugeordnet werden soll.
Zelle (4,1) weil in den Zeilen 1-3 die Buttons sowie Zeilenüberschriften stehen.

Meine Datenstruktur in Overview ist wie folgt:

Spalte A: Art.Nr.
B: Bezeichnung
C: Tracking Type
D: Kategorie
E: Lieferant
F: Ansprechpartner
G: Kritisch
H: ABC Klasse
I: Status
J: Projekt

 

@Excel121150

Bitte schau auch mal im anderen Forum (Kommentar von Steve)
Ich habe in einer Vorversion versucht, den Supplier Name als Suchkriterium zu integrieren, leider hat mir das Programm falsche Werte für Status und Prio übernommen.

 

Ich würde dir gerne auch meine Datei schicken, dann ist es glaub ich schneller verständlich, was getan werden soll.
Hier kann ich sie nicht hochladen, da zu groß.

Andere Möglichkeit?
Mail?

 

Hallo,

ich konnte diesen Effekt reproduzieren - offenbar hast du im Arbeitsblatt "Project_Import" innerhalb der Liste der zu testenden Werte in Spalte B leere Zellen, was natürlich tödlich enden muss, denn das Makro findet im Arbeitsblatt "Overview" in Spalte A über 1 Million solcher Leerzellen und trägt dann in Spalte I die entsprechenden Werte aus Spalte K des Blattes "Project_Import" ein. Damit konnte ich nun wirklich nicht rechnen. Damit solche Unsinnigkeiten nicht wieder auftreten können, habe ich einen zusätzlichen Test auf Leerwert für die Variable "CelStatus" eingefügt.

Soll das heißen, dass die FIND-Funktion bereits ab Zelle .Cells(4,1) = Overview!A4 suchen soll? Wenn dem so ist, muss die FIND-Funktion wie folgt lauten:
Set rFoundStatus = .Columns("A").Find(What:=CelValueStatus, After:=.Cells(3, 1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
denn die Suche der FIND-Funktion beginnt im Suchbereich (also Spalte A von Overview) in der ersten Zelle NACH (deshalb AFTER:=...) dieser Zelle. Findet die FIND/FINDNEXT-Funktion in den nachfolgenden Zellen des Suchbereichs nichts mehr, beginnt sie wieder in der ersten Zelle des Suchbereichs zu suchen, also in diesem Fall in Overview!$A$1 (und nicht wieder in $A$4)

Um dies flexibel und im Makro überall konsistent handhaben zu können, habe ich eine zusätzliche Variable eingefügt und ihr den entsprechenden Wert zugewiesen
HeaderRowNr = 3
d.h. alle Zellen in den ersten 3 Zeilen von Blatt "Overview" gehören zum Kopfbereich. Und das Makro wurde so umgestellt, dass es in diesem Bereich nicht sucht, sondern die Suche erst in Zeile 4 (Overview!A4) beginnt und auch hinterdrein nicht wieder im Kopfbereich zu suchen beginnt.

In der beiliegenden Excel-Datei ist eine Demoversion enthalten mit 2 Arbeitsblättern "Project_Import" und "Overview".
Im allgemeinen Codemodul "Modul1" ist dein Makro in modifizierter Form enthalten.

 

Hallo Anton Exl,

ich habe deinen Code entsprechend an meine Tabelle angepasst und es funktioniert sehr gut.
Ja ich habe vergessen zu erwähnen, dass in "Project_Import" Leerzeilen und -zellen sind.
Auch die HeaderRowNr hat sehr gut funktioniert.

Sollten in den Makros weitere Änderungen gefordert werden, bzw. Probleme auftauchen die ich nicht gelöst bekomme, hoffe ich, dass ich mich nochmal melden kann... :)

Vielen Dank für deine Hilfe!