Microsoft Excel

Herbers Excel/VBA-Archiv

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Copy & Paste

nach unten

Betrifft: Copy & Paste von: Tom
Geschrieben am: 08.10.2020 11:07:14

Hallo Zusammen,

ich bekomme einen Fehler und finde den Grund nicht.
Die Tabelleninhalte sollen über den Code unter Berücksichtigung der Parameter in eine eigene Tabelle übernommen werden.

https://www.herber.de/bbs/user/140009.xlsx

Die Prozedur bleibt hier hängen. 

Set objListA = wksAusw.ListObjects(1)
Die Vorlage hat sich nicht geändert.

Der Code sieht wie folgt aus.
Option Explicit

Sub prcCopy_to_Auswertung()
'
  'übertragung bestimmter Zeilen aus Protokoll in Auswertung
'
    Dim wkbP As Workbook, wksProtokoll As Worksheet
    Dim objListP As ListObject, objListA As ListObject
    Dim wkbAusw As Workbook, wksAusw As Worksheet
    Dim strPfadAusw As String, strDateiAusw As String
    Dim i As Integer, strTitel As String
    Dim zeiP As Long
    Dim rngCopy As Range, rngA As Range
    Dim varLfdNr As Variant, varID
    
    Const bolUeberschreiben As Boolean = True 'Wenn False, dann werden beim _
      Aktualisieren schon vorhandene Einträge nicht überschrieben
    
        Set wkbP = ActiveWorkbook
       Set wksProtokoll = ActiveSheet
    
    
    'Auswertungsdatei auswählen
    With Application.FileDialog(msoFileDialogOpen)
      .Title = "Bitte die Auswertungsdatei/letzte Angebotsdatei auswählen!"
      .InitialFileName = strPfadAusw & "\"
      .AllowMultiSelect = False
      If .Show = -1 Then
        strDateiAusw = .SelectedItems(1)
      Else
        Exit Sub
      End If
    End With
    
    'Auswertungsdatei/Angebotsdatei schreibgeschützt öffnen
    Set wkbAusw = Application.Workbooks.Open(strDateiAusw, ReadOnly:=True)
    
    Set wksAusw = wkbAusw.Worksheets(1)
    Set objListA = wksAusw.ListObjects(1)
    
    wkbAusw.Activate
    Application.ScreenUpdating = False
    
    'Tabellen/ListObjects im Blatt "Protokoll" abarbeiten
    For i = 1 To wksProtokoll.ListObjects.Count
    
      Set objListP = wksProtokoll.ListObjects(i)

      With objListP
        With .DataBodyRange
          For zeiP = 1 To .Rows.Count
              'Prüfen, ob Spalte B (BV-Version) mit Inhalt und Spalte Y (Datum Antwort) leer
              If .Cells(zeiP, 2) <> "" And .Cells(zeiP, 25) = "" Then
                varLfdNr = .Cells(zeiP, 1).Value
                varID = "LO" & Format(i, "00") & "|" & Format(varLfdNr, "000")
                'zu kopierenden Bereich (APlaten A bis L) setzen
                Set rngCopy = .Range(.Cells(zeiP, 1), .Cells(zeiP, 12))
                With objListA
                  If .ListRows.Count = 0 Then 'Listobject hat nur eine Titelzeile und eine _
                        Datenzeile ohne Daten
                    .Range.Cells(2, 1) = varID
                    rngCopy.Copy
                    .Range.Cells(2, 2).PasteSpecial
                    .ListRows.Add
                  Else
                    With .DataBodyRange
                      'ID in Spalte A suchen
                      Set rngA = .Columns(1).Find(varID, LookIn:=xlValues, lookat:=xlWhole)
                      If rngA Is Nothing Then 'neuer Eintrag
                        rngCopy.Copy
                        .Cells(.Rows.Count, 2).PasteSpecial Paste:=xlPasteValues
                        .Cells(.Rows.Count, 1).Value = varID
                        objListA.ListRows.Add
                      Else  'Eintrag schon vorhanden
                        If bolUeberschreiben = True Then
                          rngCopy.Copy
                          rngA.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
                        End If
                      End If
                    End With '.DataBodyRange
                  End If
                End With 'objListA
              End If
          Next zeiP
        End With
      End With 'objListP
    Next i
    Application.CutCopyMode = False
    objListA.DataBodyRange.EntireRow.AutoFit
    Application.ScreenUpdating = True
End Sub

Public Function fncCheckSheetName(wkb As Workbook, strSheetName As String) As Boolean
  Dim objSheet As Object
  On Error GoTo Fehler
  Set objSheet = wkb.Sheets(strSheetName)
  fncCheckSheetName = True
Fehler:
End Function
Kann bitte jemand einen Blick drüber werfen. Ich denke es ist nur eine Kleinigkeit.

Danke und viele Grüße
Tom

nach oben  nach unten

Betrifft: AW: Copy & Paste
von: Daniel
Geschrieben am: 08.10.2020 11:40:32

Hi
ist die Datei im Anhang jetzt die Datei, die das Makro enthält oder die Datei, die bei Workbooks.Open geöffnet werden soll?
Gruß Daniel

nach oben  nach unten

Betrifft: AW: Copy & Paste
von: Tom
Geschrieben am: 08.10.2020 12:05:15

Hallo Daniel,

nein, die Datei im Anhang ist eine Beispieldatei und wird über Workbooks.Open geöffnet. Die Inhalte dieser Date sollen über den Code in eine eigene Datei kopieret werden. Für jede Angebotsnummer gibt es/dann nur eine Datei. Ich möchte den Code in PERSONAL.XLSB ablegen.

Gruß Tom

nach oben  nach unten

Betrifft: oder-Fragen sollte man nicht mit
von: Daniel
Geschrieben am: 08.10.2020 12:09:33

ja oder nein beantworten (es sei denn man man wird explizit gefraget "ja oder nein").
die einzige Erklärung, die ich habe für einen Fehler an dieser Stelle, ist, dass das angesprochene Tabellenblatt in der geöffneten Datei kein Listobjekt enthält.
Gruß Daniel

nach oben  nach unten

Betrifft: AW: oder-Fragen sollte man nicht mit
von: Tom
Geschrieben am: 08.10.2020 12:18:28

....verstanden. Sorry! Werde ich in Zukunft berücksichtigen.

Ok, es ist kein Listobjekt. Was ist es dann?

Der ursprüngliche Code u. f. hat funktioniert. Es sollte lediglich eingeschränkt werden auf den zu übertragenden Bereich von Spalte 1 bis 12.
                'zu kopierenden Bereich (APlaten A bis L) setzen
                Set rngCopy = .Range(.Cells(zeiP, 1), .Cells(zeiP, 12))
Sub prcCopy_to_Auswertung()
'
  'übertragung bestimmter Zeilen aus Protokoll in Auswertung
'
    Dim wkbP As Workbook, wksProtokoll As Worksheet
    Dim objListP As ListObject, objListA As ListObject
    Dim wkbAusw As Workbook, wksAusw As Worksheet, strPfadAusw As String, strDateiAusw As  _
String
    Dim i As Integer, strTitel As String
    Dim zeiP As Long
    Dim rngCopy As Range, rngA As Range
    Dim varLfdNr As Variant, varID
    
    Const bolUeberschreiben As Boolean = True 'Wenn False, dann werden beim Aktualisieren schon  _
vorhandene Einträge nicht überschrieben
    strPfadAusw = "C:\Users\Public\Test\"     'Verzeichnis mit der Auswertungs-Datei  'anpassen! _
!
    strDateiAusw = "Auswertung.xlsx"          'Name der Auswertungs-Datei - ggf. anpassen!!
    
    'Offene Arbeitsmappe mit Blatt "Protokoll" suchen
    For Each wkbP In Application.Workbooks
      If fncCheckSheetName(wkbP, "Protokoll") = True Then
        Set wksProtokoll = wkbP.Worksheets("Protokoll")
        Exit For
      End If
    Next
    If wkbP Is Nothing Then
      MsgBox " Die Datei mit dem Blatt ""Protokoll"" ist nicht geöffnet!", vbOKOnly, "Daten in  _
Auswertung übertragen"
      Exit Sub
    End If
    
    
    'Prüfen, ob die Auswertungsdatei vorhanden ist
    If Dir(strPfadAusw & strDateiAusw) <> "" Then
      'Prüfen, ob Auswertungsdatei göffnet
      For Each wkbAusw In Application.Workbooks
        If LCase(wkbAusw.Name) = LCase(strDateiAusw) Then Exit For
      Next
      
      If wkbAusw Is Nothing Then
        'Auswertungsdatei öffnen
        Set wkbAusw = Application.Workbooks.Open(strDateiAusw)
      End If
      
      Set wksAusw = wkbAusw.Worksheets(1)
      Set objListA = wksAusw.ListObjects(1)
      
      wkbAusw.Activate
      Application.ScreenUpdating = False
      
      'Tabellen/ListObjects im Blatt "Protokoll" abarbeiten
      For i = 1 To wksProtokoll.ListObjects.Count
      
        Set objListP = wksProtokoll.ListObjects(i)

        With objListP
          With .DataBodyRange
            For zeiP = 1 To .Rows.Count
                'Prüfen, ob Spalte B (BV-Version) mit Inhalt und Spalte Y (Datum Antwort) leer
                If .Cells(zeiP, 2) <> "" And .Cells(zeiP, 25) = "" Then
                  varLfdNr = .Cells(zeiP, 1).Value
                  varID = "LO" & Format(i, "00") & "|" & Format(varLfdNr, "000")
                  Set rngCopy = .Rows(zeiP)
                  With objListA
                    If .ListRows.Count = 0 Then 'Listobject hat nur eine Titelzeile und eine  _
Datenzeile ohne Daten
                      .Range.Cells(2, 1) = varID
                      rngCopy.Copy
                      .Range.Cells(2, 2).PasteSpecial
                      .ListRows.Add
                    Else
                      With .DataBodyRange
                        'ID in Spalte A suchen
                        Set rngA = .Columns(1).Find(varID, LookIn:=xlValues, lookat:=xlWhole)
                        If rngA Is Nothing Then 'neuer Eintrag
                          rngCopy.Copy
                          .Cells(.Rows.Count, 2).PasteSpecial Paste:=xlPasteValues
                          .Cells(.Rows.Count, 1).Value = varID
                          objListA.ListRows.Add
                        Else  'Eintrag schon vorhanden
                          If bolUeberschreiben = True Then
                            rngCopy.Copy
                            rngA.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
                          End If
                        End If
                      End With '.DataBodyRange
                    End If
                  End With 'objListA
                End If
            Next zeiP
          End With
        End With 'objListP
      Next i
      Application.CutCopyMode = False
      objListA.DataBodyRange.EntireRow.AutoFit
      Application.ScreenUpdating = True
    Else
      MsgBox "Datei " & vbLf & strDateiAusw & vbLf & "nicht gefunden!", _
          vbOKOnly, "Daten in Auswertung übertragen"
    End If
En




Gruß Tom

nach oben  nach unten

Betrifft: AW: oder-Fragen sollte man nicht mit
von: Tom
Geschrieben am: 08.10.2020 12:48:07


Der Plan war es in der Datei den Code hinterlegt zu haben.

https://www.herber.de/bbs/user/140729.xlsx

Der Fehler sagt dann aus das die Tabelle in der Datei kein ListObjekt ist?


Gruß Tom

nach oben  nach unten

Betrifft: AW: oder-Fragen sollte man nicht mit
von: Daniel
Geschrieben am: 08.10.2020 13:12:14

Hi

wenn du hier "Set objListA = wksAusw.ListObjects(1)" einen Fehler bekommst und alles andere vorher durchgelaufen ist, dann kann das meiner Ansicht nach nur daran liegen, dass das tabellenblatt wksAusw kein Listobjekt ("intelligente Tabelle") enthält
Gruß Daniel

nach oben  nach unten

Betrifft: AW: oder-Fragen sollte man nicht mit
von: Tom
Geschrieben am: 08.10.2020 13:41:53

Hallo,

das sehe ich auch so. In der Auswertungstabelle ist aber eine intelligente Tabelle vorhanden.

Der ursprüngliche Code hat alle Inhalte übertragen. Da hat es noch funktioniert. Erst als der Übertrag eingeschränkt wurde, funktioniert es nicht mehr.

Keine Ahnung ist erkenne den Fehler nicht....

Gruß Tom

nach oben  nach unten

Betrifft: AW: oder-Fragen sollte man nicht mit
von: Daniel
Geschrieben am: 08.10.2020 13:55:18

"Übertragung eingeschränkt?"
was bedeutet das?

nach oben  nach unten

Betrifft: AW: oder-Fragen sollte man nicht mit
von: Tom
Geschrieben am: 08.10.2020 14:06:33

Hi,

es werden nicht mehr alle Spalten übertragen.

wurde ersetzt 
Set rngCopy = .Rows(zeiP)

durch 
Set rngCopy = .Range(.Cells(zeiP, 1), .Cells(zeiP, 12))
Gruß Tom

nach oben  nach unten

Betrifft: Copy & Paste
von: Tom
Geschrieben am: 09.10.2020 10:10:32

Hallo,

hat noch jemand eine Idee?


Option Explicit
         
         Sub prcCopy_to_Auswertung()
         '
           'übertragung bestimmter Zeilen aus Protokoll in Auswertung
         '
             Dim wkbP As Workbook, wksProtokoll As Worksheet
             Dim objListP As ListObject, objListA As ListObject
             Dim wkbAusw As Workbook, wksAusw As Worksheet
             Dim strPfadAusw As String, strDateiAusw As String
             Dim i As Integer, strTitel As String
             Dim zeiP As Long
             Dim rngCopy As Range, rngA As Range
             Dim varLfdNr As Variant, varID
             
             Const bolUeberschreiben As Boolean = True 'Wenn False, dann werden beim _
               Aktualisieren schon vorhandene Einträge nicht überschrieben
             
                 Set wkbP = ActiveWorkbook
                Set wksProtokoll = ActiveSheet
             
             
             'Auswertungsdatei auswählen
             With Application.FileDialog(msoFileDialogOpen)
               .Title = "Bitte die Auswertungsdatei/letzte Angebotsdatei auswählen!"
               .InitialFileName = strPfadAusw & "\"
               .AllowMultiSelect = False
               If .Show = -1 Then
                 strDateiAusw = .SelectedItems(1)
               Else
                 Exit Sub
               End If
             End With
             
             'Auswertungsdatei/Angebotsdatei schreibgeschützt öffnen
             Set wkbAusw = Application.Workbooks.Open(strDateiAusw, ReadOnly:=True)
             
             Set wksAusw = wkbAusw.Worksheets(1)
             Set objListA = wksAusw.ListObjects(1)
             
             wkbAusw.Activate
             Application.ScreenUpdating = False
             
             'Tabellen/ListObjects im Blatt "Protokoll" abarbeiten
             For i = 1 To wksProtokoll.ListObjects.Count
             
               Set objListP = wksProtokoll.ListObjects(i)
         
               With objListP
                 With .DataBodyRange
                   For zeiP = 1 To .Rows.Count
                       'Prüfen, ob Spalte B (BV-Version) mit Inhalt und Spalte Y (Datum Antwort) _
 leer
                       If .Cells(zeiP, 2) <> "" And .Cells(zeiP, 25) = "" Then
                         varLfdNr = .Cells(zeiP, 1).Value
                         varID = "LO" & Format(i, "00") & "|" & Format(varLfdNr, "000")
                         'zu kopierenden Bereich (APlaten A bis L) setzen
                         Set rngCopy = .Range(.Cells(zeiP, 1), .Cells(zeiP, 12))
                         With objListA
                           If .ListRows.Count = 0 Then 'Listobject hat nur eine Titelzeile und  _
eine _
                                 Datenzeile ohne Daten
                             .Range.Cells(2, 1) = varID
                             rngCopy.Copy
                             .Range.Cells(2, 2).PasteSpecial
                             .ListRows.Add
                           Else
                             With .DataBodyRange
                               'ID in Spalte A suchen
                               Set rngA = .Columns(1).Find(varID, LookIn:=xlValues, lookat:= _
xlWhole)
                               If rngA Is Nothing Then 'neuer Eintrag
                                 rngCopy.Copy
                                 .Cells(.Rows.Count, 2).PasteSpecial Paste:=xlPasteValues
                                 .Cells(.Rows.Count, 1).Value = varID
                                 objListA.ListRows.Add
                               Else  'Eintrag schon vorhanden
                                 If bolUeberschreiben = True Then
                                   rngCopy.Copy
                                   rngA.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
                                 End If
                               End If
                             End With '.DataBodyRange
                           End If
                         End With 'objListA
                       End If
                   Next zeiP
                 End With
               End With 'objListP
             Next i
             Application.CutCopyMode = False
             objListA.DataBodyRange.EntireRow.AutoFit
             Application.ScreenUpdating = True
         End Sub

Public Function fncCheckSheetName(wkb As Workbook, strSheetName As String) As Boolean
           Dim objSheet As Object
           On Error GoTo Fehler
           Set objSheet = wkb.Sheets(strSheetName)
           fncCheckSheetName = True
         Fehler:
         End Function


nach oben  nach unten

Betrifft: AW: Copy & Paste
von: fcs
Geschrieben am: 09.10.2020 13:07:48

Hallo Tom,

ich hab das Makro jetzt von der persönlichen Makroarbeitsmappe aus mit den beiden Dateien getestet. Der angegebene Fehler tritt mit den Testdateien nicht auf.
Es wird aber nicht der korrekte Zellbereich kopiert. Es tritt ein Zeilenversatz auf.
Ich hab das Setzen des zu kopierenden Zellbereichs angepasst. Es wird jetzt nicht mehr die Zeilen-Nummer im DataBodyRange verwendet, sondern die Zeilen-Nummer im Tabellenblatt berechnet und der zu kopierende Bereich entsprechend gesetzt.

Die Function fncCheckSheetName wird in dieser Version des Makros nicht mehr benötigt.

LG

Franz
         
Sub prcCopy_to_Auswertung()
'
  'übertragung bestimmter Zeilen aus Protokoll in Auswertung
'
    Dim wkbP As Workbook, wksProtokoll As Worksheet
    Dim objListP As ListObject, objListA As ListObject
    Dim wkbAusw As Workbook, wksAusw As Worksheet
    Dim strPfadAusw As String, strDateiAusw As String
    Dim i As Integer, strTitel As String
    Dim zeiP As Long
    Dim zeiTab As Long                                   'neu fcs 2020-10-09
    Dim rngCopy As Range, rngA As Range
    Dim varLfdNr As Variant, varID
    
    Const bolUeberschreiben As Boolean = True 'Wenn False, dann werden beim _
      Aktualisieren schon vorhandene Einträge nicht überschrieben
    
    Set wkbP = ActiveWorkbook
    Set wksProtokoll = ActiveSheet
    
    
    'Auswertungsdatei auswählen
    With Application.FileDialog(msoFileDialogOpen)
      .Title = "Bitte die Auswertungsdatei/letzte Angebotsdatei auswählen!"
      .InitialFileName = strPfadAusw & "\"
      .AllowMultiSelect = False
      If .Show = -1 Then
        strDateiAusw = .SelectedItems(1)
      Else
        Exit Sub
      End If
    End With
    
    'Auswertungsdatei/Angebotsdatei schreibgeschützt öffnen
    Stop
    Set wkbAusw = Application.Workbooks.Open(strDateiAusw, ReadOnly:=True)
    
    Set wksAusw = wkbAusw.Worksheets(1)
    Set objListA = wksAusw.ListObjects(1)
    
    wkbAusw.Activate
    Application.ScreenUpdating = False
    
    'Tabellen/ListObjects im Blatt "Protokoll" abarbeiten
    For i = 1 To wksProtokoll.ListObjects.Count
    
      Set objListP = wksProtokoll.ListObjects(i)

      With objListP
        With .DataBodyRange
          For zeiP = 1 To .Rows.Count
              'Prüfen, ob Spalte B (BV-Version) mit Inhalt und Spalte Y (Datum Antwort) leer
              If .Cells(zeiP, 2) <> "" And .Cells(zeiP, 25) = "" Then
                varLfdNr = .Cells(zeiP, 1).Value
                varID = "LO" & Format(i, "00") & "|" & Format(varLfdNr, "000")
                'zu kopierenden Bereich (Spalten A bis L) setzen
                zeiTab = zeiP + .Row - 1                            'neu fcs 2020-10-09
                With wksProtokoll                                   'neu fcs 2020-10-09
                  Set rngCopy = .Range(.Cells(zeiTab, 1), .Cells(zeiTab, 12)) 'geändert fcs  _
2020-10-09
                End With                                            'neu fcs 2020-10-09
                With objListA
                  If .ListRows.Count = 0 Then 'Listobject hat nur eine Titelzeile und _
eine _
                        Datenzeile ohne Daten
                    .Range.Cells(2, 1) = varID
                    rngCopy.Copy
                    .Range.Cells(2, 2).PasteSpecial
                    .ListRows.Add
                  Else
                    With .DataBodyRange
                      'ID in Spalte A suchen
                      Set rngA = .Columns(1).Find(varID, LookIn:=xlValues, lookat:=xlWhole)
                      If rngA Is Nothing Then 'neuer Eintrag
                        rngCopy.Copy
                        .Cells(.Rows.Count, 2).PasteSpecial Paste:=xlPasteValues
                        .Cells(.Rows.Count, 1).Value = varID
                        objListA.ListRows.Add
                      Else  'Eintrag schon vorhanden
                        If bolUeberschreiben = True Then
                          rngCopy.Copy
                          rngA.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
                        End If
                      End If
                    End With '.DataBodyRange
                  End If
                End With 'objListA
              End If
          Next zeiP
        End With
      End With 'objListP
    Next i
    Application.CutCopyMode = False
    objListA.DataBodyRange.EntireRow.AutoFit
    Application.ScreenUpdating = True
End Sub


nach oben  nach unten

Betrifft: AW: Copy & Paste
von: Tom
Geschrieben am: 09.10.2020 14:33:38

Hallo Franz,

vielen Dank für Deine erneute Unterstützung.
Leider bleibe ich jetzt beim Stop hängen und gehe dann mit F8 weiter bis dann wieder der ListObjekt Fehler kommt. Ich kapiere es nicht....bei Dir geht's bei mir nicht. Die erste Version hat wunderbar funktioniert...

Damit wir nicht aneinander vorbei reden. Der neue Code ist in der persönlichen Arbeitsmappe hinterlegt. Wenn ich eine bereits erstellte Auswertdatei öffnen möchte dann einfach das Makro ausführen lassen. Wenn ich eine neue Datei erstellen möchte, dann muss die Auswertevorlage geöffnet sein. Habe ich das schon richtig verstanden?

VG Tom

nach oben  nach unten

Betrifft: AW: Copy & Paste
von: fcs
Geschrieben am: 09.10.2020 15:57:41

Hallo Tom,

die Stop-Zeile kannst du löschen.

Die hatte ich zum Testen eingebaut und vergessen wieder zu löschen.

LG
Franz