Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Zelle vergleichen

Frage Entwicklung VB for Applications

Mitglied: Gimli3311

Gimli3311 (Level 1) - Jetzt verbinden

23.02.2015, aktualisiert 24.02.2015, 629 Aufrufe, 4 Kommentare

Hallo Zusammen,
Hallo jodel32,

Ich habe 2 Excel-Dateien mit Tabellen nun haben die Tabellen verschiedene Vorlagen.
Ich hab also ein aktuelle Vorlage und verschiedene ältere Vorlagen.
Nun will ich die aktuelle Vorlage mit den anderen Dateien (die unteranderem ältere Vorlagen haben, vergleichen) und die älteren Vorlagen raussortieren(bzw. überspringen).

Mein Vorgehen wäre dieses:
Öffne Logbuch_Master_Vorlage
Öffne Logbuch_xx
Wenn die Überschrift (A28) von Logbuch_xx gleich ist wie von Logbuch_Master_Vorlage (A1) dann:
Wenn die Überschrift (B28) von Logbuch_xx gleich ist wie von Logbuch_Master_Vorlage (B1) dann:
..............wenn alles übereinstimmt kopiere einen Bereich....ist schon programmiert (Danke jodel32 ;) )
Stimmt NICHT überein schließe Logbuch_xx und kehre in die Schleife zurück --> Logbuch_xx öffnen

01.
Option Compare Text 'benötigt für einen 'like' Vergleich 
02.
 
03.
Dim fso As Object 'Variable ganz am Anfang des Codefensters stehen lassen ! 
04.
Dim wb As Workbook 
05.
 
06.
 
07.
Sub ImportTables() 
08.
 
09.
    'Variabeln werden mit passenden Datentypen gesetzt 
10.
     Dim rngOut As Range, f As Variant, objFoundFiles As New Collection, strFileFilter As String 
11.
 
12.
    'FilesystemObject erstellen 
13.
     Set fso = CreateObject("Scripting.Filesystemobject") 
14.
 
15.
    'Pfad in dem die *.xlsx Dateien liegen wird mit der Funktion fncBrowseForFolder ausgewählt 
16.
    'andere Möglichkeit direkter Pfad angeben= (PATHFILES muss dann CONST gesetzt werden) "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test" 
17.
 
18.
    'Greif auf die Funktion fncBrowseForFolder zu um einen Ordner auszuwählen 
19.
    PATHFILES = fncBrowseForFolder 
20.
    'Inputbox wird erstellt in der das Suchwort eingegeben werden soll 
21.
    strFileFilter = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_* (ohne Datei-Erweiterung, es werden nur *.xlsx, *.xlsm und *.xls Dateien gesucht)") 
22.
 
23.
 
24.
    'Suche Dateien mit passenden Namen 
25.
 
26.
    enumFiles fso.GetFolder(PATHFILES), strFileFilter, objFoundFiles 
27.
 
28.
    'Wenn Dateien gefunden wurden 
29.
    If objFoundFiles.Count > 0 Then 
30.
        'Führt das Makro schneller aus und unterdrückt Meldungen 
31.
        Application.ScreenUpdating = False 
32.
        Application.DisplayAlerts = False 
33.
 
34.
        With ActiveSheet 
35.
            'erste Ausgabezelle in neuer .xlsx-Datei festlegen 
36.
            Set rngOut = .Range("A3") 
37.
            'Für jede gefundene Datei in der Collection 
38.
            For Each f In objFoundFiles 
39.
                'öffne Datei 
40.
                Set wb = Workbooks.Open(f, ReadOnly:=True) 
41.
                'kopiere den Inhalt der Tabelle in das aktuelle Sheet 
42.
                 
43.
                '-Vorlage vergleichen--- 
44.
                 
45.
                With wb.Sheets(1) 
46.
                    .Range("A29:N" & .Cells(Rows.Count, 4).End(xlUp).Row).Copy rngOut 
47.
                 End With 
48.
                'schließe Dokument wieder 
49.
                wb.Close False 
50.
                'Ausgabezelle für den nächsten Import ermitteln 
51.
                Set rngOut = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
52.
            Next 
53.
            '----Funktionsaufruf um Leere Spalten zu löschen 
54.
           deleteEmptyCells 
55.
             
56.
        End With 
57.
        Application.ScreenUpdating = True 
58.
        Application.DisplayAlerts = True 
59.
 
60.
    End If 
61.
 
62.
End Sub 
63.
 
64.
' Öffnet das Suchfeld für die Ordnerauswahl 
65.
 
66.
 
67.
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String 
68.
 
69.
  Dim objFlderItem As Object, objShell As Object, objFlder As Object 
70.
 
71.
 
72.
  Set objShell = CreateObject("Shell.Application") 'Vordefinierter Pfad einstellen zu Testzwecken (Standard--> DefaultPath) 
73.
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, "I:\Projects-Global\ITIS\") 
74.
 
75.
  If objFlder Is Nothing Then GoTo ErrExit 
76.
 
77.
  Set objFlderItem = objFlder.Self 
78.
  fncBrowseForFolder = objFlderItem.Path 
79.
 
80.
ErrExit: 
81.
  Set objShell = Nothing 
82.
  Set objFlder = Nothing 
83.
  Set objFlderItem = Nothing 
84.
 
85.
End Function 
86.
 
87.
 
88.
Function deleteEmptyCells() 
89.
 
90.
 Dim lngLetzte As Long 
91.
 Dim lngZeile As Long 
92.
 ' Bildschirmaktualisierung AUSschalten (Makro läuft schneller, Bildschirm flackert nicht) 
93.
 Application.ScreenUpdating = False 
94.
 ' Letzte belegte Zelle in Spalte B plus 1 raussuchen und merken 
95.
 lngLetzte = IIf(IsEmpty(Range("B65536")), Range("B65536").End(xlUp).Row + 1, 65536) 
96.
 ' in einer Schleife von dieser Letzten bis Zeile 1 gehen - also von unten nach oben 
97.
      For lngZeile = lngLetzte To 1 Step -1 
98.
    ' Wenn die Zelle in der ensprechenden Zeile in Spalte B leer ist 
99.
        If Cells(lngZeile, 2) = "" Then 
100.
    ' dann lösche die gesamte Zeile 
101.
          Cells(lngZeile, 2).EntireRow.Delete 
102.
    ' Ende der Bedingung 
103.
        End If 
104.
    ' Nächste Zeile mit der Bedingung vergleichen 
105.
      Next 
106.
 ' Bildschirmaktualisierung EINschalten (nicht vergessen) 
107.
 Application.ScreenUpdating = True 
108.
 
109.
 
110.
End Function 
111.
 
112.
'Funktion um Dateien rekursiv zu suchen 
113.
 
114.
 
115.
Sub enumFiles(ByVal rootFolder As Object, ByVal strFilter As String, ByRef col As Collection) 
116.
 
117.
    On Error Resume Next 
118.
    For Each file In rootFolder.Files 
119.
        ext = LCase(fso.GetExtensionName(file.Name)) 
120.
        If fso.GetBasename(file.Name) Like strFilter And (ext = "xlsx" Or ext = "xls") Then 
121.
            col.Add file.Path 
122.
        End If 
123.
    Next 
124.
    For Each subfolder In rootFolder.SubFolders 
125.
        enumFiles subfolder, strFilter, col 
126.
    Next 
127.
 
128.
End Sub
Mitglied: Eintagsfliege
LÖSUNG 24.02.2015, aktualisiert um 11:10 Uhr
Hallo Gimli3311!

Das Ganze noch ein wenig übersichtlicher, dann in etwa so:
01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
'Start-Pfad für Ordnerauswahl festlegen 
05.
Private Const RootFolder = "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\" 
06.
 
07.
Private objFso As Object, objFileList As New Collection 
08.
Private arrFileMask As Variant, intSubFolders As Integer 
09.
 
10.
Public Sub ImportTables() 
11.
    Dim objWks As Worksheet, rngPaste As Range, sInput As String 
12.
    Dim strFileName As Variant, strRootFolder As String, i As Long 
13.
     
14.
    With ActiveSheet 
15.
        'Erste Zelladresse für Import fetlegen 
16.
        Set rngPaste = .Range("A5") 
17.
         
18.
        'Sheet ab Range-Paste vor Import gegebenenfalls bereinigen 
19.
        If .UsedRange.Rows.Count >= rngPaste.Row Then 
20.
            .Rows(rngPaste.Row & ":" & .UsedRange.Rows.Count).Clear 
21.
        End If 
22.
    End With 
23.
 
24.
    'Dialog Ordnerauswahl anzeigen 
25.
    With Application.FileDialog(msoFileDialogFolderPicker) 
26.
        .Title = "Ordnerauswahl . . ." 
27.
        .ButtonName = "Öffnen" 
28.
        .InitialFileName = RootFolder 
29.
         If .Show Then 
30.
             strRootFolder = .SelectedItems(1) 
31.
         End If 
32.
    End With 
33.
     
34.
    'Test Ordnerauswahl Leer/Abbruch 
35.
    If strRootFolder = "" Then Exit Sub 
36.
     
37.
    'Abfrage Root-Ordner rekursiv durchsuchen Ja/Nein 
38.
    intSubFolders = MsgBox("Unterordner mit einbeziehen?", vbQuestion Or vbYesNo, "Dateisuche . . .") 
39.
     
40.
    'Eingabe-Text 
41.
    sInput = "Datei-Suchmuster eingeben (erlaubt *?):" & vbCr & vbCr & _ 
42.
             "Beispiele: [*.xls] [*.xls*] [*.xls;*.xlsx]" 
43.
     
44.
    'Eingabe Datei-Suchmuster 
45.
    arrFileMask = Split(InputBox(sInput, "Dateisuche . . .", "*.xls*"), ";") 
46.
     
47.
    'Test ob Datei-Suchmuster Leer/Abbruch 
48.
    If UBound(arrFileMask) < 0 Then Exit Sub 
49.
     
50.
    'Object mit Dateifunktionen erzeuegen 
51.
    Set objFso = CreateObject("Scripting.FileSystemObject") 
52.
 
53.
    'Dateiliste erstellen 
54.
    Call FindFiles(objFso.GetFolder(strRootFolder)) 
55.
     
56.
    'Test Dateien gefunden 
57.
    If objFileList.Count Then 
58.
        With ActiveSheet 
59.
            'Bildschirmaktualisierung Aus 
60.
            Application.ScreenUpdating = False 
61.
         
62.
            'Dateiliste abarbeiten und Daten importieren 
63.
            For Each strFileName In objFileList 
64.
                'Daten importieren 
65.
                Set objWks = Workbooks.Open(strFileName, ReadOnly:=True).Sheets(1) 
66.
                 
67.
                'Kopieren, wenn Überschriften übereinstimmen 
68.
                If .Range("A1").Value & .Range("B1").Value Like objWks.Range("A28").Value & objWks.Range("B28").Value Then 
69.
                    objWks.Range("A29:N" & objWks.Cells(Rows.Count, "B").End(xlUp).Row).Copy rngPaste 
70.
                End If 
71.
                 
72.
                objWks.Parent.Close False 
73.
                 
74.
                'Nächste Zelladresse für Import festlegen 
75.
                Set rngPaste = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
76.
            Next 
77.
             
78.
            'Zeilen löschen wenn Spalte B = Leer (RowsCount = 1048576) 
79.
            For i = .Cells(Rows.Count, "B").End(xlUp).Row To 5 Step -1 
80.
                If .Cells(i, "B").Text = "" Then 
81.
                    .Rows(i).Delete Shift:=xlUp 
82.
                End If 
83.
            Next 
84.
        End With 
85.
 
86.
        'Bildschirmaktualisierung Ein 
87.
        Application.ScreenUpdating = True 
88.
         
89.
        MsgBox "Datenimport abgeschlossen!", vbInformation, "Datenimport . . ." 
90.
    Else 
91.
        MsgBox "Keine Dateien gefunden!", vbInformation, "Dateisuche . . ." 
92.
    End If 
93.
    Set objFileList = Nothing 
94.
End Sub 
95.
 
96.
'Root-Ordner nach Dateien durchsuchen (rekursiv MsgBox Ja/Nein) 
97.
Private Sub FindFiles(ByRef objFolder) 
98.
    Dim objFile As Object, objSubFolder As Object, strFileMask As Variant 
99.
     
100.
    For Each objFile In objFolder.Files 
101.
        For Each strFileMask In arrFileMask 
102.
            If objFile.Name Like strFileMask Then 
103.
                objFileList.Add objFile.Path 
104.
            End If 
105.
        Next 
106.
    Next 
107.
     
108.
    If intSubFolders = vbYes Then 
109.
        For Each objSubFolder In objFolder.SubFolders 
110.
            Call FindFiles(objSubFolder) 
111.
        Next 
112.
    End If 
113.
End Sub
Grüße Dieter

[edit] Geändert: FileList zurücksetzen und Löschen des Importbereichs an den Anfang gesetzt(sichtbar) [/edit]
Bitte warten ..
Mitglied: Gimli3311
24.02.2015, aktualisiert um 09:21 Uhr
Vielen Dank Dieter

Funktioniert fast wie es sollte.

Ich hab da noch paar Fragen bzw. Probleme:

1. Wenn die gefundene Datei geöffnet wird erscheint diese Abfrage:
8d545fbbb240311d6d10220793aa617b - Klicke auf das Bild, um es zu vergrößern

kann ich die irgendwie vermeiden oder automatisch beantworten.
Und meine Frage ist auch wieso erscheint Sie überhaupt?

2. Ich soll ja nach Dateien suchen die "Logbuch" im Namen haben und den Dateityp ".xls" oder ".xlsx"
Meine Frage ist jetzt wo gibst du im Programm an das er nach dem Dateinamen "*Logbuch*" suchen muss? Das mit den Dateitypen kann ich nachvollziehen.
EDIT: Man bin ich blöd: Ich gebe in die Inputbox dann einfach ein *Logbuch*.xls; *Logbuch*.xlsx
Hat auch ohne funktioniert ^^

3. Das Problem hatte ich schon vorher und zwar hat jedes Logbuch eine Überschrift, bei den aktuellen Logbüchern steht sie in A28 bis N28
In meinem Code kopiere ich aber erst ab Zelle A29 bis N29 wieso bekomm ich trotzdem jedes Mal die Überschrift mit.

Anmerkung: Ich hatte das Problem das wenn ich das Makro mehrmals ausgeführt habe (davor die Zeilen mit den Ergebnissen gelöscht habe) kamen die Daten mehrmals vor Beispiel:

1. Ausgeführt --> Alle Daten richtig kopiert und eingefügt
2. Ausgeführt --> Daten doppelt kopiert und eingefügt
3. Ausgeführt --> Daten dreifach kopiert und eingefügt

Lösung: Habe in Zeile 91 "Set objFileList = Nothing" gesetzt

Schon mal vielen Dank für die Hilfe
Bitte warten ..
Mitglied: Eintagsfliege
24.02.2015 um 10:53 Uhr
Hallo

Freut mich, dass Du mitgedacht hast

Das zurücksetzen der FileList hatte ich leider nicht bedacht. Des weiteren habe ich das Löschen der Inhalte noch an den Anfang gesetzt, damit dies noch vor 'Bildschirmaktualisierung Aus' sichtbar geschieht (oben geändert) ...

3. Das Problem hatte ich schon vorher und zwar hat jedes Logbuch eine Überschrift, bei den aktuellen Logbüchern steht sie in A28 bis N28
In meinem Code kopiere ich aber erst ab Zelle A29 bis N29 wieso bekomm ich trotzdem jedes Mal die Überschrift mit.
Kann es sein, dass bei diesen Dateien in Spalte B (ab Zeile 29) nix drin steht, wenn ja, dann ändere in Codezeile 69 das "B" in eine Spaltenbezeichnung um, in der auf jeden Fall was drinsteht...

Grüße Dieter
Bitte warten ..
Mitglied: Gimli3311
24.02.2015 um 11:10 Uhr
Ja will ja etwas vom VBA lernen

Das mit dem Löschen des Inhaltes hat soweit gepasst, werde ich aber ändern und an den Anfang setzen wie du es gemacht hast.

Habe das Problem gerade gelöst hatte in Zeile 46:
01.
 .Range("A29:N" & .Cells(Rows.Count, 4).End(xlUp).Row).Copy rngOut 
bei Rows.Count 4 steht hab diese auf 1 abgeändert und jetzt geht's ;)

Danke für deine Hilfe
Gruß Sergej
Bitte warten ..
Neuester Wissensbeitrag
Festplatten, SSD, Raid

12TB written pro SSD in 2 Jahren mit RAID5 auf Hyper-VServer

Erfahrungsbericht von Lochkartenstanzer zum Thema Festplatten, SSD, Raid ...

Ähnliche Inhalte
Windows Server
AD-Berechtigungen von zwei Servern miteinander vergleichen (3)

Frage von s0m3ting zum Thema Windows Server ...

Batch & Shell
gelöst Powershell - Dateien aus verschiedenen Arrays - Attribute vergleichen (5)

Frage von Giffas zum Thema Batch & Shell ...

Heiß diskutierte Inhalte
Windows Userverwaltung
Ausgeschiedene Mitarbeiter im Unternehmen - was tun mit den AD Konten? (34)

Frage von patz223 zum Thema Windows Userverwaltung ...

LAN, WAN, Wireless
gelöst Server erkennt Client nicht wenn er ausserhalb des DHCP Pools liegt (28)

Frage von Mar-west zum Thema LAN, WAN, Wireless ...

Windows Server
Server 2008R2 startet nicht mehr (Bad Patch 0xa) (18)

Frage von Haures zum Thema Windows Server ...