AW: Wert in Mappe1 suchen und in Mappe2 einfügen
14.10.2014 21:18:12
Raphael
Hallo Thorsten
Option Explicit
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
Dim intNr As Integer
Dim intName As Integer
Dim intStatus As Integer
Dim intAnzZeilen As Integer
Dim intAnzZeilen2 As Integer
Dim objNamen As Object
Dim strNamen As String
Dim strPfad As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim wb As Workbook
Dim arr As Variant
'Pfad anpassen
strPfad = "C:\Users\Quelle.xls"
Set objNamen = CreateObject("Scripting.Dictionary")
'Ausschalten der Bildschirmaktualisierung, verhindert das die Datei sichtbar angezeigt wird
Application.ScreenUpdating = False
Set wb = Workbooks.Open(strPfad, , True) 'Datei wird im Lesemodus geöffnet (Schreibgeschü _
tzt)
Set ws1 = wb.Sheets("Tabelle1")
Set ws2 = ThisWorkbook.Sheets("Tabelle1")
arr = ws1.UsedRange
wb.Close 'Workbook wieder schliessen
Application.ScreenUpdating = True
'Zeilen zählen
intAnzZeilen2 = ws2.Cells(Rows.Count, 7).End(xlUp).Row
'Im der Zieldatei vorhandene Einträge löschen
ws2.Range(ws2.Cells(2, 1), ws2.Cells(intAnzZeilen2 + 1, 25)).Clear
'String mit den einzelnen Namen erstellen für Inputbox
intNr = 1
For i = 2 To UBound(arr)
Debug.Print arr(i, 7)
If Not objNamen.exists(arr(i, 7)) And arr(i, 7) "" Then
objNamen.Add arr(i, 7), intNr
strNamen = strNamen & intNr & " : "
strNamen = strNamen & arr(i, 7) & vbCrLf
intNr = intNr + 1
End If
Next i
intName = InputBox(strNamen, "Bitte Namen wählen") - 1
Debug.Print objNamen.keys()(intName)
'Alle Zeilen die den Status offen haben in "Tabelle2" kopieren
intAnzZeilen = ws2.Cells(Rows.Count, 7).End(xlUp).Row + 1
For i = 2 To UBound(arr)
If arr(i, 7) = objNamen.keys()(intName) And arr(i, 10) = "offen" Then
'Werte in Zeile einfügen
For j = 1 To UBound(arr, 2)
ws2.Cells(intAnzZeilen, j).Value = arr(i, j)
Next j
intAnzZeilen = intAnzZeilen + 1
End If
Next i
Set wb = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set objNamen = Nothing
End Sub
Gruess
Raphael