@tino - was mache ich verkehrt?
25.11.2014 09:04:46
Wolfgang
den nachfolgenden Code hattest Du mir vor kurzem überlassen (finde leider den maßgeblichen Thread nicht mehr). Er funktioniert auch soweit wunderbar. Nun hatte ich überlegt, ihn für eine andere Abfrage umzustellen. Dieses gelingt mir aber nur teilweise. Bezugsspalten sind dabei nun A und P (umgestellt somit auf: rngAlt.FormulaR1C1 = "=RC1&RC16"
rngNeu.FormulaR1C1 = "=IF(Countif(" & rngAlt.Address(1, 1, xlR1C1) & ",RC1&RC16)>0,TRUE,ROW())"
rngNeu.EntireRow.Sort Key1:=rngNeu, Order1:=xlAscending, Header:=xlNo
Die angesprochene Tabelle ist nun die Tabelle6.
Irgendwie funktioniert die Umstellung auch bedingt, aber es werden irgendwie die Zeilen verschoben. Welche Schnittstellen müsste ich insgesamt verändern, um nun aus Tabelle I_Output.xlsx in Tabelle6 und Bezugnahme Spalte A und Spalte P den Abgleich bzw. Import vorzunehmen?
Danke schon jetzt für Deine Rückmeldung (nachfolgend Dein Originalcode).
Herzliche Grüße Wolfgang
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