PDA

Vollständige Version anzeigen : Daten auslesen / exportieren


Shoutz000
12.07.2016, 17:05
Hallo,

also ich habe das Forum soweit nach meinem Problem durchsucht, aber bisher nichts gefunden was mir wirklich zum Erfolg verhilft. Daher nun die direkte Frage.

Aufgabe ist folgende:
Wir lesen unsere Stücklisten der Konstruktion (CAD) nach Excel aus. In diesen Stücklisten sind Ersatzteile enthalten, welche in eine gesamte Liste für den Kunden zusammengefasst werden sollen. Nun habe ich eine Ersatzteilliste (identisch zur Stückliste) und gebe per Userform den Pfad des Konstruktionsverzeichnisses an. Aus diesem Verzeichnis werden alle Stücklisten (auch aus den Unterordnern) geöffnet. Die Stückliste erstreckt sich von A bis Q. Ob es ein Ersatzteil ist, steht in L und ist mit einem "X" markiert. Nun sollen alle Stücklisten in dem angegebenen Verzeichnis geöffnet werden (funktioniert), anschließend soll die Spalte L der geöffneten Stücklisten nach allen "X" durchsucht werden. Für jedes "X" soll die gesamte Zeile (A:Q) in die Ersatzteilliste eingefügt werden (funktioniert nicht). Wenn alle "X" abgearbeitet sind, soll die Stückliste geschlossen und die nächste Stückliste geöffnet werden (funktioniert).

Das Ermitteln aller Zellen mit "X" in der Spalte L und der Export der gesamten Zeilen funktioniert bisher überhaupt nicht...

Ich hoffe dass irgendjemand helfen kann :-)


Aktueller Code (SourceFolderName ist die Pfadeingabe (...\Ordner\)):


Sub Open_SL(SourceFolderName As String)
' Alle Stücklisten im Verzeichnis öffnen
Dim i As Integer
Dim oFound As Range
Dim oItem As Variant
Dim oRow As Integer
oRow = 12
Dim oDocName As String
oDocName = ActiveWorkbook.Name
Dim oTarget As Object
Set oTarget = Workbooks(oDocName).Worksheets("Stückliste")

Dim SourceFolder As Object, SubFolder As Object, NextMap$
On Error Resume Next
Set SourceFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderName)
NextMap = Dir(SourceFolder.Path & "\*.xlsm")
Do While NextMap <> ""
If Not SourceFolder.Path & "\" & NextMap = ThisWorkbook.FullName Then Workbooks.Open SourceFolder.Path & "\" & NextMap
' Prüfen ob Ersatzteile enthalten sind
Const SearchNumb = 2
Dim SearchItem(SearchNumb) As String
SearchItem(1) = "X"
SearchItem(2) = "x"

' HIER WIRD DAS PROBLEM LIEGEN?!
For i = 1 To SearchNumb
Set oFound = Workbooks(NextMap).Worksheets(1).Range("L12:L352").Find(SearchItem(i), LookIn:=xlValues)
If Not oFound Is Nothing Then
oItem = Range(Cells(1, oFound.Row), Cells(17, oFound.Row)).Value
oTarget.Range(Cells(1, oRow), Cells(17, oRow)).Value = oItem
oRow = oRow + 1
End If
Next
' HIER WIRD DAS PROBLEM LIEGEN?!

Workbooks(NextMap).DisplayAlerts = False
Workbooks(NextMap).Close SaveChanges:=False
oRow = oRow + 1

NextMap = Dir()
Loop

For Each SubFolder In SourceFolder.SubFolders
Open_SL SubFolder.Path
Next SubFolder

Set SourceFolder = Nothing
Set SubFolder = Nothing
On Error GoTo 0
End Sub

Storax
12.07.2016, 18:10
Set oFound = Workbooks(NextMap).Worksheets(1).Range("L12:L352").Find(SearchItem(i), LookIn:=xlValues)Dein Code findet so das erste X und nicht mehr. Du brauchst so etwas http://www.cpearson.com/excel/findall.aspx. Obwohl man in Deinem Fall das sicher einfacher machen kann.

xlph
12.07.2016, 18:24
Versuche es hiermit...

Public Sub TEST_ImportData()
Call ImportData("D:\Test")
End Sub

Public Sub ImportData(ByVal strPath As String)

Dim fso As Object
Dim colPath As Collection
Dim vntPath As Variant

Dim avntData() As Variant

Dim lngTargetRow As Long

Dim wksTarget As Worksheet


Set wksTarget = ThisWorkbook.Worksheets("Stückliste")

Set colPath = New Collection

Set fso = CreateObject("Scripting.FileSystemObject")
Call OrdnerListen(fso, strPath, colPath, "Stückliste*.xlsm")
Set fso = Nothing


Application.ScreenUpdating = False

lngTargetRow = 2

For Each vntPath In colPath
If vntPath <> ThisWorkbook.FullName Then

With Workbooks.Open(vntPath, 0, True)
avntData() = GetData(.Worksheets(1).Range("A12:Q352"), "x", 12)
.Close False
End With

If (Not avntData()) <> -1 Then
wksTarget.Cells(lngTargetRow, 1).Resize(UBound(avntData, 1), UBound(avntData, 2)).Value = avntData
lngTargetRow = lngTargetRow + UBound(avntData, 1)
Erase avntData
End If

End If
Next

Set wksTarget = Nothing
Set colPath = Nothing

Application.ScreenUpdating = True

End Sub

Private Sub OrdnerListen(fso As Object, Ordnerangabe As String, col As Collection, Optional ByVal strSearchFile As String = "*.*")
Dim o, uo, f

strSearchFile = LCase$(strSearchFile)

Set o = fso.GetFolder(Ordnerangabe)

For Each f In o.Files
If LCase$(f.Name) Like strSearchFile Then
col.Add f.Path
End If
Next

For Each uo In o.SubFolders
Call OrdnerListen(fso, uo.Path, col, strSearchFile)
Next

Set o = Nothing
Set uo = Nothing

End Sub

Private Function GetData(ByRef rngData As Range, vntSearchValue As Variant, lngSerachColumn As Long) As Variant()
Dim avntData() As Variant
Dim iavntData1 As Long
Dim iavntData2 As Long

Dim avntResult() As Variant
Dim iavntResult1 As Long

Dim lngCount As Long

With rngData

lngCount = WorksheetFunction.CountIf(rngData.Columns(lngSerachColumn), vntSearchValue)

If lngCount > 0 Then

ReDim avntResult(1 To lngCount, 1 To .Columns.Count)
avntData() = .Value

For iavntData1 = LBound(avntData, 1) To UBound(avntData, 1)
If StrComp(avntData(iavntData1, lngSerachColumn), vntSearchValue, vbTextCompare) = 0 Then
iavntResult1 = iavntResult1 + 1
For iavntData2 = LBound(avntData, 2) To UBound(avntData, 2)
avntResult(iavntResult1, iavntData2) = avntData(iavntData1, iavntData2)
Next
End If
Next

GetData = avntResult()

End If

End With

End Function

Shoutz000
13.07.2016, 17:32
Hi vielen Dank.

@Storax die Seite ist eigentlich nicht schlecht, aber ich bekomme es nicht annähernd funktionsfähig verarbeitet... bin noch nicht so weit glaube ich.

@xlph ich habe eigentlich alles angepasst, aber ich schaffe es nicht mal dass Dein Code überhaupt die Exceltabellen aus dem Verzeichnis öffnet?!

Ich würde aber eigentlich auch gerne meinen bisherigen Code beibehalten. Alle Exceltabellen aus dem Verzeichnis öffnen und wieder schließen funktioniert ja auch einwandfrei. Nur die Zeilen mit X in die aktuelle Tabelle zu exportieren nicht. :sos:

xlph
13.07.2016, 17:43
Call OrdnerListen(fso, strPath, colPath, "Stückliste*.xlsm")

entfernen

Shoutz000
15.07.2016, 08:59
Ach du scheiße natürlich :-)
Oje
Funktioniert :yelrotfl:

Vielen vielen Dank

Shoutz000
19.07.2016, 10:45
Hi,

also ich habe noch ein "Problem" bei dem Ihr vielleicht eine Lösung kennt, da ich bisher nicht fündig geworden bin. Es passt zwar thematisch nicht ganz hier her, aber da es um die gleiche Datei geht frage ich trotzdem mal hier.

Und zwar habe ich in der Datei viele Subs die immer wieder die Informationen benötigen welche die letzte befüllte Zeile ist und welche die Letzte Zeile in der Tabelle (die letzte formatierte Zeile. Die benutzten Zeilen in der Liste sind weiß, der Schriftkopf entsprechend unterschiedlich formatiert und alle anderen Zeilen sind dunkelgrau also nach Ende der eigentlichen Liste).
Diese Suchfunktion wird also entsprechend oft aufgerufen und in den Subs aus denen ich diese Funktion aufrufe muss ich immer wieder das Blatt sperren / entsperren. Ich würde es gerne vermeiden dass in den Suchsubs auch ständig gesperrt / entsperrt werden muss.
Beim suchen der letzten befüllten Zeile ist das auch nicht nötig. Wenn ich aber nach der letzten formatierten Zeile suche muss ich das Blatt entsperren. Geht das vielleicht auch ohne?!

Letzte befüllte Zeile:

Public Sub SearchLastRowUsed()
' Letzte befüllte Zeile ermitteln
Dim i As Integer
LastRowUsed = 0

LastRowUsed = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row - 1
For i = LastRowUsed To 1 Step -1
If WorksheetFunction.CountIf(ActiveSheet.Rows(i), "") <> ActiveSheet.Columns.Count Then
LastRowUsed = i + 2
Exit For
End If
Next i
End Sub


Letzte formatierte Zeile:

Public Sub SearchLastRowFormat()
' Blatt entsperren
Call SheetUnprotect

' Letzte formatierte Zeile ermitteln
Dim i As Integer
LastRowFormat = 10

For i = 1 To Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(i, 1).Interior.ColorIndex = 2 Then
LastRowFormat = LastRowFormat + 1
End If
Next i

' Blatt sperren
Call SheetProtect
End Sub