Herbers Excel/VBA-Archiv

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

zeilenweise importieren, wenn noch nicht vorhanden

• zeilenweise importieren, wenn noch nicht vorhanden von Wolfgang vom 18.11.2014 17:40:32
• AW: zeilenweise importieren, wenn noch nicht vorhanden - von Tino am 18.11.2014 18:37:34
  • AW: zeilenweise importieren, wenn noch nicht vorhanden - von Wolfgang am 19.11.2014 08:23:47
    • AW: zeilenweise importieren, wenn noch nicht vorhanden - von Tino am 19.11.2014 16:47:52
      • Danke Tino!!! - von Wolfgang am 20.11.2014 12:55:44
        • danke für die Rückmeldung! oT. - von Tino am 20.11.2014 16:33:56

Betrifft: zeilenweise importieren, wenn noch nicht vorhanden von: Wolfgang
Geschrieben am: 18.11.2014 17:40:32

Hallo,
in einem Arbeitsordner befinden sich diverse „Bezugs-Mappen“ und auch die „Ziel-Mappe“, aus der Abfragen, wie nachfolgend, erfolgen.
In die aktuell geöffnete Mappe, so bewirkt der jetzige Code, werden alle Zeilen aus der Mappe „I_Eingaenge.xlsx, Tabelle1-„ in Tabelle7 importiert/eingefügt. Vorher wird mit einem anderen Code zunächst der Inhalt der Tabelle7 gelöscht (Dieser Vorgang wäre bei evtl. Umsetzung meines Wunsches dann hinfällig).
Wie kann der Code verändert werden, dass abgeglichen wird, welche Datensätze/Zeilen sich bereits in Tabelle7 befinden, so dass in der Folge nur noch die noch nicht vorhandenen Datensätze/Zeilen aus I_Eingaenge.xlsx in Tabelle7 importiert werden.
Maßgebliche Spalten für das Vorhandensein sind die Spalten I in Verbindung mit Spalte K.
Wäre ein solches Verfahren möglich bzw. die Abänderung des folgenden Codes denkar?
Danke schon jetzt für die Rückantworten.
Herzliche Grüße - Wolfgang

Sub I_Daten_Lesen()
Dim oApp As Excel.Application
Dim ArrayData
Dim strFile As String
Dim MaxRow As Long
Application.ScreenUpdating = False
strFile = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
strFile = strFile & "I_Eingaenge.xlsx"


Set oApp = New Excel.Application

On Error GoTo ErrorHandler:
With oApp
    With oApp.Workbooks.Open(strFile, ReadOnly:=True)
        .Close False
    End With
End With

If IsArray(ArrayData) Then
    With Tabelle7
        .Range("A1", .Cells(.Rows.Count, 57)).ClearContents
        .Range("A1").Resize(UBound(ArrayData), UBound(ArrayData, 2)) = ArrayData
    End With
End If

ErrorHandler:
oApp.Quit
Set oApp = Nothing

If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, "Error: " & _
 Err.Number, Err.HelpFile, Err.HelpContext
End If
Application.ScreenUpdating = True
End Sub

Betrifft: AW: zeilenweise importieren, wenn noch nicht vorhanden von: Tino
Geschrieben am: 18.11.2014 18:37:34

Hallo,
kannst mal so testen.
Bin mir nicht sicher ob ich alles verstanden habe!
Wo wird bei dir ArrayData gefüllt?

Sub test()
Dim rngAlt As Range, rngNeu As Range
Dim oApp As Excel.Application
Dim ArrayData
Dim strFile As String
Dim MaxRow As Long


'... 
'... 
'       dein anderer Code 
'... 
'... 

If IsArray(ArrayData) Then
    With Tabelle7
         MaxRow = FindLetzte(Sheets(.Name)).Row
         If MaxRow > 1 Then
            MaxRow = MaxRow + 1
            Set rngAlt = .Range(.Cells(1, .Columns.Count), .Cells(MaxRow - 1, .Columns.Count))
            Set rngNeu = .Cells(MaxRow, .Columns.Count).Resize(Ubound(ArrayData))
         End If
         With .Cells(MaxRow, 1).Resize(Ubound(ArrayData), Ubound(ArrayData, 2))
            .Value = ArrayData
            If MaxRow > 1 Then
                rngAlt.FormulaR1C1 = "=RC9&RC11"
                rngNeu.FormulaR1C1 = "=IF(Countif(" & rngAlt.Address(1, 1, xlR1C1) & ",RC9&RC11)>0,TRUE,ROW())"
                rngNeu.EntireRow.Sort Key1:=rngNeu, Order1:=xlAscending, Header:=xlNo

                If Application.WorksheetFunction.CountIf(rngNeu, True) > 0 Then
                    Set rngNeu = rngNeu.SpecialCells(xlCellTypeFormulas, 4)
                End If

                If Not rngNeu Is Nothing Then rngNeu.EntireRow.Delete
                rngAlt.EntireColumn.Delete
            End If
         End With
    End With
End If

End Sub

Function FindLetzte(mySH As Worksheet) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
 
 With mySH.UsedRange
   On Error Resume Next
        'Finde Zeile 
        LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
        LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
        If LRow = 0 Then LRow = 1
   
        'Finde Spalte 
        For A = .Columns(.Columns.Count).Column To .Columns(1).Column Step -1
              LCol = mySH.Columns(A).Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Column
              LCol = Application.Max(LCol, mySH.Columns(A).Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Column)
              If LCol > 1 Then: LCol = A: Exit For
        Next A
        If LCol = 0 Then LCol = 1
 End With
 
 Set FindLetzte = mySH.Cells(LRow, LCol)
End Function

Gruß Tino

Betrifft: AW: zeilenweise importieren, wenn noch nicht vorhanden von: Wolfgang
Geschrieben am: 19.11.2014 08:23:47

Hallo Tino,
herzlichen Dank für Deine schnelle Rückmeldung und Deine Ausarbeitungen. Ich habe versucht, sie umzusetzen/einzubauen. Das gelingt mir noch nicht. Irgendwie finde ich nicht den Bezug zur Mappe I_Eingaenge.xlsx. VB soll, so wäre mein Wunsch, ja zwischen Tabellenblatt7 der geöffneten Mappe und der Mappe I_Eingaenge-Tabelle1- abgleichen, ob sich in der Mappe I_Eingange.. noch Zeilen befinden, die das Tabellenblatt7 noch nicht enthält, um diese dann noch in Tabelle7 zu kopieren (ans Ende gestellt). Danke schon jetzt wieder für Deine erneute Rückmeldung.
Herzliche Grüße - Wolfgang

Betrifft: AW: zeilenweise importieren, wenn noch nicht vorhanden von: Tino
Geschrieben am: 19.11.2014 16:47:52

Hallo,
die Daten müssten doch noch vorhanden sein in ArrayData,
der Teil fehlt im gezeigten Code von dir wo diese Daten übergeben werden!

Versuche es mal so?

Sub I_Daten_Lesen()
Dim rngAlt As Range, rngNeu As Range
Dim oApp As Excel.Application
Dim ArrayData
Dim strFile As String
Dim MaxRow As Long

Call Events_(False)

'Pfad zur Quelldatei 
strFile = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
strFile = strFile & "I_Eingaenge.xlsx"
 
Set oApp = New Excel.Application

On Error GoTo ErrorHandler:

With oApp
    With oApp.Workbooks.Open(strFile, ReadOnly:=True)
       With .Sheets("Tabelle1") 'Tabelle wo Daten stehen 
                       'Datenbereich Quelle Range 
           ArrayData = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 56)
       End With
       .Close False
    End With
End With

If IsArray(ArrayData) Then
    With Tabelle7
         MaxRow = FindLetzte(Sheets(.Name)).Row
         If MaxRow > 1 Then
            MaxRow = MaxRow + 1
            Set rngAlt = .Range(.Cells(1, .Columns.Count), .Cells(MaxRow - 1, .Columns.Count))
            Set rngNeu = .Cells(MaxRow, .Columns.Count).Resize(Ubound(ArrayData))
         End If
         With .Cells(MaxRow, 1).Resize(Ubound(ArrayData), Ubound(ArrayData, 2))
            .Value = ArrayData
            If MaxRow > 1 Then
                rngAlt.FormulaR1C1 = "=RC9&RC11"
                rngNeu.FormulaR1C1 = "=IF(Countif(" & rngAlt.Address(1, 1, xlR1C1) & ",RC9&RC11)>0,TRUE,ROW())"
                rngNeu.EntireRow.Sort Key1:=rngNeu, Order1:=xlAscending, Header:=xlNo

                If Application.WorksheetFunction.CountIf(rngNeu, True) > 0 Then
                    Set rngNeu = rngNeu.SpecialCells(xlCellTypeFormulas, 4)
                End If

                If Not rngNeu Is Nothing Then rngNeu.EntireRow.Delete
                rngAlt.EntireColumn.Delete
            End If
         End With
    End With
End If

ErrorHandler:

oApp.Quit
Set oApp = Nothing

If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, "Error: " & _
 Err.Number, Err.HelpFile, Err.HelpContext
End If

Call Events_(True)
End Sub

Function FindLetzte(mySH As Worksheet) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
 
 With mySH.UsedRange
   On Error Resume Next
        'Finde Zeile 
        LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
        LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
        If LRow = 0 Then LRow = 1
   
        'Finde Spalte 
        For A = .Columns(.Columns.Count).Column To .Columns(1).Column Step -1
              LCol = mySH.Columns(A).Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Column
              LCol = Application.Max(LCol, mySH.Columns(A).Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Column)
              If LCol > 1 Then: LCol = A: Exit For
        Next A
        If LCol = 0 Then LCol = 1
 End With
 
 Set FindLetzte = mySH.Cells(LRow, LCol)
 On Error GoTo 0
 
End Function

Sub Events_(booSchalter As Boolean)
With Application
    .ScreenUpdating = booSchalter
    .EnableEvents = booSchalter
    .DisplayAlerts = booSchalter
    .Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub

Gruß Tino

Betrifft: Danke Tino!!! von: Wolfgang
Geschrieben am: 20.11.2014 12:55:44

Hallo Tino,
erneut zunächst recht herzlichen Dank für Deine Rückmeldung und Überlassung des neuen Codes. Ich habe ihn "eingebaut" und verschiedentlich getestet. Ich konnte keine Unwägbarkeiten/Fragezeichen feststellen. Er läuft m.E. tadellos und macht genau das, was ich mir gewünscht hatte. Hab nochmals vielen Dank - Du hast mir sehr geholfen!!
Gruß und einen schönen Tag noch, Wolfgang

Betrifft: danke für die Rückmeldung! oT. von: Tino
Geschrieben am: 20.11.2014 16:33:56

Beiträge aus den Excel-Beispielen zum Thema "zeilenweise importieren, wenn noch nicht vorhanden"