PDA

Vollständige Version anzeigen : Import Check durch VBA


Pascal1988
21.07.2014, 08:12
Guten Tag zusammen,

dies ist meine erste Forenerfahrung, darum bitte ich um Nachsicht, sollte ich eine Regel versehentlich brechen.

Auf Arbeit gibt es für mich die Anforderung aus verschiedenen Datenquellen eine Tabelle zu erstellen, die die Pflege in SAP erleichtern soll.
Dabei möchte ich aus Datei A den gesamten Datenbereich in Tabelle B übertragen. Soweit auch kein Problem.

Um jedoch zu verhindern, dass das Makro doppelt ausgeführt wird und wir redundante Daten haben, möchte ich vor der Übertragung ein Schlüsselfeld checken. Jedoch fehlt mir der komplette Ansatz eines IF-Blocks.



- In Spalte A von Datei A befinden sich die Schlüsselwerte, Zelle A2 sollte zum Abgleich reichen (eine eindeutige Nummer).

- Nimm Wert aus Zelle A2

- Wechsel in Datei B und Suche im Tabellenblatt "XY" und dort Spalte A nach diesem Wert.

- Wird der Wert gefunden, Abbrechen mit Message Box:"Daten bereits vorhanden"

- Wird der Wert nicht gefunden, weiterverfahren mit dem einfügen der Daten.


Leider habe ich kaum einen Ansatz. Durch das Aufzeichnen der Schritte bekomme ich zwar das Suchfenster Strg+F. Ich hatte gedacht, dass ich der Zelle A2 in Datei 1 vielleicht einen Namen geben kann wie "Suchwort" und diesen standardmäßig in die Suchmaske einfügen kann. Des Weiteren dachte ich, dass ein IF NOT sinnvoller ist als ein IF?

Kann mir jmd. mit diesem Problem behilflich sein?

Viele Grüße & Dank im Voraus

Pascal

MWOnline
21.07.2014, 08:19
Hallöchen!

Hier ein Ansatz:

Sub AbgleichMakro()
Dim z As Long
Dim oSuchTabelle As Object
Dim sSuchWert As String

sSuchWert = ThisWorkbook.Sheets(1).Cells(2, 1).Value 'Zelle A2

Set oSuchTabelle = ActiveWorkbook.Sheets(2) 'Hier evtl. andere Datei und korretes Sheet einfügen!

For z = 1 To oSuchTabelle.UsedRange.Rows.Count + oSuchTabelle.UsedRange.Row - 1

'Spalte A durchsuchen
If LCase(Trim(CStr(sSuchWert))) = LCase(Trim(CStr(oSuchTabelle.Cells(z, 1).Value))) Then
MsgBox "Wert in Zeile " & z & " bereits vorhanden!", vbInformation + vbOKOnly, "Achtung!"
Exit For
End If

Next z

Set oSuchTabelle = Nothing
End Sub


Allerdings solltest Du bedenken,Makros aus Foren sind ohne Support und Service ;) Wenn mal etwas dringend ist auf der Arbeit hast Du keine Möglichkeit schnelle garantierte Hilfe zu bekommen ;)

Beste Grüße und Viel Erfolg beim Einbau
Marc

Hajo_Zi
21.07.2014, 08:21
Hallo Pascal,

Option Explicit

Sub test()
' erstellt von HajoZiplies@web.de 21.07.03
Dim RaFound As Range
Set RaFound = Workbooks("Datei2.xlsm").Worksheets("Xy").Columns(1).Find(Range("A2"), Range("A" & Rows.Count), xlFormulas, _
xlWhole, , xlNext)
If Not RaFound Is Nothing Then
MsgBox "gefunden"
End If
Set RaFound = Nothing
End Sub


<img src="http://Hajo-Excel.de/images/grusz1.gif" align="middle" height="40" alt="Grußformel"><a href="http://Hajo-Excel.de/index.htm"><img border="0" src="http://Hajo-Excel.de/images/logo_hajo3.gif" align="middle" height="40" alt="Homepage"></a>

xlph
21.07.2014, 09:39
Hallo Pascal1988,

hier noch ein Variante:

Option Explicit

Public Sub DatenAbgleichen_xlph()

' Bemerkung: Quell- und Zieltabelle müssen Text-Übderschriften haben.

' Q = Quelle, Z = Ziel

Dim Blatt_Q As Worksheet
Dim Blatt_Z As Worksheet

Dim IDs_Q As Variant
Dim IDs_Z As Variant

Dim ID_Idx As Long

Dim ID_Collection As Collection

Dim Daten_Q As Variant

Dim Daten_Neu As Variant

Dim ID_N_IdxR As Long
Dim ID_N_IdxC As Long


Set Blatt_Q = Workbooks("NameDateiQuelle.xlsx").Worksheets("BlattName") ' Anpassen *****
Set Blatt_Z = Workbooks("NameDateiZiel.xlsm").Worksheets("BlattName") ' Anpassen *****

IDs_Q = Blatt_Q.Range("A1").CurrentRegion.Columns(1).Value
IDs_Z = Blatt_Z.Range("A1").CurrentRegion.Columns(1).Value

Set ID_Collection = New Collection

' Ziel-IDs zum Vergleichen ab Zeile 2 einlesen
For ID_Idx = LBound(IDs_Z) + 1 To UBound(IDs_Z)
ID_Collection.Add Item:=IDs_Z(ID_Idx, 1), Key:=CStr(IDs_Z(ID_Idx, 1))
Next

' Quell-IDs mit Ziel-IDs ab Zeile 2 vergleichen. Bei Übereinstimmung Merker in Quell-ID löschen
For ID_Idx = LBound(IDs_Q) + 1 To UBound(IDs_Q)
If CollectionKeyExist(ID_Collection, CStr(IDs_Q(ID_Idx, 1))) Then
IDs_Q(ID_Idx, 1) = 0
Else
IDs_Q(ID_Idx, 1) = 1
End If
Next

If WorksheetFunction.Sum(IDs_Q) > 0 Then

Daten_Q = Blatt_Q.Range("A1").CurrentRegion.Value

ReDim Daten_Neu(LBound(Daten_Q) To WorksheetFunction.Sum(IDs_Q), LBound(Daten_Q, 2) To UBound(Daten_Q, 2))

' Alle übrig gebliebenen (=neu) Quell-IDs mit ihren Daten in einem Ergebnis-Array sammeln
For ID_Idx = LBound(IDs_Q) + 1 To UBound(IDs_Q)

If IDs_Q(ID_Idx, 1) = 1 Then

ID_N_IdxR = ID_N_IdxR + 1
For ID_N_IdxC = LBound(Daten_Q, 2) To UBound(Daten_Q, 2)
Daten_Neu(ID_N_IdxR, ID_N_IdxC) = Daten_Q(ID_Idx, ID_N_IdxC)
Next

End If
Next

' Neu ermittelte Daten (Ergebnis-Array) in Ziel-Tabelle ausgeben
With Blatt_Z.Range("A" & Blatt_Z.Rows.Count).End(xlUp).Offset(1).Resize(UBound(Daten_Neu), UBound(Daten_Neu, 2))
.Value = Daten_Neu
' --- Formatierung ---
.Interior.Pattern = xlGray25
.Interior.PatternColor = 49407
' --------------------
End With

MsgBox UBound(Daten_Neu) & " neue Datensätze wurden erfolgreich in Ziel-Tabelle hinzugefügt!"
Else

MsgBox "Keine neuen Daten!"

End If

Set Blatt_Q = Nothing
Set Blatt_Z = Nothing

Set ID_Collection = Nothing

End Sub

Public Function CollectionKeyExist(ByRef colData As Collection, ByVal strKey As String) As Boolean
On Error Resume Next
CollectionKeyExist = (VarType(colData(strKey)) > -1)
On Error GoTo 0
End Function