Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1392to1396
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

zeilenweise importieren, wenn noch nicht vorhanden

zeilenweise importieren, wenn noch nicht vorhanden
18.11.2014 17:40:32
Wolfgang
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

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: zeilenweise importieren, wenn noch nicht vorhanden
18.11.2014 18:37:34
Tino
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

Anzeige
AW: zeilenweise importieren, wenn noch nicht vorhanden
19.11.2014 08:23:47
Wolfgang
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

Anzeige
AW: zeilenweise importieren, wenn noch nicht vorhanden
19.11.2014 16:47:52
Tino
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

Anzeige
Danke Tino!!!
20.11.2014 12:55:44
Wolfgang
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

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

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige