Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema CommandButton
BildScreenshot zu CommandButton CommandButton-Seite mit Beispielarbeitsmappe aufrufen

Wert in Mappe1 suchen und in Mappe2 einfügen

Betrifft: Wert in Mappe1 suchen und in Mappe2 einfügen von: Thorsten Lazarski
Geschrieben am: 13.10.2014 21:05:32

Hallo zusammen,

ich habe eine Sitzungsprotokoll. In mehreren Zeilen stehen Zuständigkeiten und ein Status"offen"...immer in der gleichen Spalte.Ich möchte über einen Commandbutton in das Protokoll nach dem Namen(Zuständigkeit) und Status "offen" suchen lassen und die Zeile in die 1. Mappe kopieren. Die Zeile soll an an der ersten freien Zeile eingefügt werden.

Könnt ihr mir helfen?

Gruss Thorsten

  

Betrifft: Musterdatei von: Raphael H
Geschrieben am: 13.10.2014 21:41:57

Hallo Thorsten,

ich denke wir können, aber damit wir nicht hemmungslos unseren Fantasien nachhängen wäre eine Musterdatei von deiner Seite sehr hilfreich.

Gruess
Raphael


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: Thorsten Lazarski
Geschrieben am: 13.10.2014 23:41:18

https://www.herber.de/bbs/user/93148.xls


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: Thorsten Lazarski
Geschrieben am: 13.10.2014 23:44:18

Hallo Raphael,

ich hoffe es wird jetzt klarer :)

Gruß Thorsten


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: Raphael H
Geschrieben am: 14.10.2014 09:15:02

Hallo Thorsten,

wäre das etwa in deinem Sinne?

Option Explicit

Private Sub CommandButton1_Click()
    Dim i As Integer
    Dim intNr As Integer
    Dim intName As Integer
    Dim intStatus As Integer
    Dim intAnzZeilen As Integer
    Dim objNamen As Object
    Dim strNamen As String
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    
    Set objNamen = CreateObject("Scripting.Dictionary")
    Set ws1 = Sheets("Tabelle1")
    Set ws2 = Sheets("Tabelle2")
    intAnzZeilen = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    
    'String mit den einzelnen Namen erstellen für Inputbox
    intNr = 1
    With ws1
        For i = 2 To intAnzZeilen
            If Not objNamen.exists(.Cells(i, 7).Value) And .Cells(i, 7).Value <> "" Then
                objNamen.Add .Cells(i, 7).Value, intNr
                strNamen = strNamen & intNr & " : "
                strNamen = strNamen & .Cells(i, 7).Value & 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
    
        For i = 2 To intAnzZeilen
            If .Cells(i, 7).Value = objNamen.keys()(intName) And .Cells(i, 10).Value = "offen"  _
Then
                'Zeile kopieren
                .Rows(i).Copy Destination:=Sheets("Tabelle2").Rows(ws2.Cells(Rows.Count, 7).End( _
xlUp).Row + 1)
            End If
        Next i
    End With
    
    Set objNamen = Nothing
    
End Sub
Gruess
Raphael


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: thorsten lazarski
Geschrieben am: 14.10.2014 09:35:52

Hallo Raphael,

danke für die schnelle Antwort.
Ich benötige eine Lösung für zwei verschiedene Excel Dateien. Quelle.xls....Ziel.xls.
Die Quelle liegt auf dem Server und wird täglich bearbeitet bzw. aktualisiert. Jeder Mitarbeiter hat eine "Ziel Datei" und soll sich aus der Quelle täglich die offenen Sachen über einen Button selber holen. Die Mitarbeiter melden per Mail die Punkte als erledigt. Ich aktualisiere Die Quelldatei. Im günstigsten Fall wird die Liste, die sich die Mitarbeiten holen täglich kürzer bzw. kommen neue Aufgaben dazu. So der Plan :)

Gruss Thorsten


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: Raphael H
Geschrieben am: 14.10.2014 12:50:45

Lässt sich im Code ohne weiteres Anpassen, die Frage ist nur ob der Rest so ok ist.

Gruess
Raphael


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: thorsten lazarski
Geschrieben am: 14.10.2014 15:52:52

Hallo Raphael,

so funktioniert es erst einmal. Wäre es möglich die alten Einträge vorher zu löschen??? Im Moment kopiert er die neuen unter die alten Sachen. Es soll ja etwa ein Refresh geben.

Gruß Thorsten


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: Raphael H
Geschrieben am: 14.10.2014 21:18:12

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


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: thorsten lazarski
Geschrieben am: 15.10.2014 16:57:04

Hallo Raphael,

erst einmal vielen Dank für deine Mühe. Wäre es noch möglich die Inputbox wegzulassen? Ich habe in der Spalte mehrere Kombinationen von Namen. z.B "Müller/Meier/Schulze". Ich möchte den Namen als Zeichenfolge suchen lassen und wenn es mehrere Zuständigkeiten gibt es auch den einzelnen Personen zuweisen können. Der Suchname könnte in der Datei in der der Button steht z.B. in Zelle "H2" stehen.

Sonst Läuft es wie gewünscht...


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: thorsten lazarski
Geschrieben am: 16.10.2014 14:09:00

Option Explicit

Private Sub CommandButton1_Click()
   Dim i As Integer
   Dim j As Integer
   Dim intNr As Integer
   Dim intName As String, xlPart
   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\MOONDAY\Documents\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) '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, 10).End(xlUp).Row
   
   'Im der Zieldatei vorhandene Einträge löschen
   ws2.Range(ws2.Cells(3, 1), ws2.Cells(intAnzZeilen2 + 1, 16)).Clear

intName = Range("H2")
    
    intAnzZeilen = ws2.Cells(Rows.Count, 10).End(xlUp).Row + 1
   For i = 2 To UBound(arr)
      If arr(i, 10) = (intName) And arr(i, 13) = "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



  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: Raphael H
Geschrieben am: 17.10.2014 08:34:33

Hallo Thorsten,

du solltest evtl. noch das suchen nach dem anpassen

    For i = 2 To UBound(arr)
        If Not arr(i, 10) = "" Then
            If InStr(1, UCase$(arr(i, 10)), UCase$(strName)) > 0 And arr(i, 13) = "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
        End If
    Next i
So werden zwar beim Müller auch die Wegmüllers angezeigt, aber falls du da keine Überschneidungen hast, sollte das so klappen.

Gruess
Raphael


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: thorsten lazarski
Geschrieben am: 17.10.2014 11:44:24

Hallo Raphael,

funktioniert super. Danke.
Auch wenn du bestimmt genervt bist...es gibt ein Problem mit der Formatierung. Ist es möglich die Formatierung der Ursprungsbereichs zu übernehmen oder zu verhindern das die Formatierung im Zielblatt überschrieben wird???

Gruss Thorsten


  

Betrifft: AW: Wert in Mappe1 suchen und in Mappe2 einfügen von: Raphael H
Geschrieben am: 17.10.2014 18:50:55

Hallo Thorsten,

es ist effizienter wenn die Formatierung im Zielblatt nicht verändert wird, da du die Netzwerkdatei dann schneller wieder freigibst.

Ersetze einfach .clear durch ein .ClearContents (dann wird nur der Inhalt gelöscht, aber die Formatierung bleibt erhalten)

ws2.Range(ws2.Cells(3, 1), ws2.Cells(intAnzZeilen2 + 1, 16)).ClearContents
Gruess
Raphael


 

Beiträge aus den Excel-Beispielen zum Thema "Wert in Mappe1 suchen und in Mappe2 einfügen"