PDA

Vollständige Version anzeigen : Makro das sich daten holt!


djell
25.04.2009, 09:55
Hallo Leute,
Wieder mal eine sache die mein wiesen übersteigt.

Ich brauche in meiner Exceldatei namens Auswertung ein Makro das sich daten von anderen holt.
Und zwar hab ich einen Ordner wo mehrere Exceldateien drin sind namens,
Sonder0001.xls
Sonder0002.xls
Sonder0003.xls
usw, und das werden auch von tag zu tag mehr.
Das Makro sollte jetzt, aus allen dateien in dem Ordner daten in meine Auswertung hollen.
Und Zwar die daten der Zellen C3, C6, A9, B10, D11, und diese dann in meiner Auswertung in einer Zeile darstellen, so das dann am schluss die datein aus allen Sonder xls in meiner Auswertung untereinander stehen.

Geht das?
Da gibt es doch bestimmt eine lösung.

Case_Germany
26.04.2009, 13:26
Hallo, :)

eine von mindestens 4 Möglichkeiten, die mir spontan einfallen. Code habe ich gerade rumliegen. Musst Du einfach noch nach den Kommentaren im Code auf Deine Gegebenheiten anpassen:

Option Explicit
Const strSheetQ As String = "Sheet1" ' Die Tabelle wird ausgelesen
Const strSheetZ As String = "Sheet1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "C3" ' Diese Zellen werden ausgelesen
Const strCellQ2 As String = "C6"
Const strCellQ3 As String = "A9"
Const strCellQ4 As String = "B10"
Const strCellQ5 As String = "D11"

Public Sub Files_Read()
Dim stCalc As XlCalculationState
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path ' Datei im gleichen Ordner wie Auswertungsdateien
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xls", True ' Mit Unterordner
dirInfo objDir, "*.xls"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub

Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim lngLastRow As Long
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
With .Cells(lngLastRow, 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ1
.Offset(0, -1).Value = varTMP.Name
End With
With .Cells(lngLastRow, 3)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ2
End With
With .Cells(lngLastRow, 4)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ3
End With
With .Cells(lngLastRow, 5)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ4
End With
With .Cells(lngLastRow, 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ5
End With
.UsedRange.Value = .UsedRange.Value
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName
Next varTMP
End If
Set objWorkbook = Nothing
End Sub

Servus
Case

BoskoBiati
26.04.2009, 13:47
Hallo djell,

vielleicht geht es hiermit (ungetestet):

Option Explicit
Public Sub Zusammenfassen()

Dim wks As Worksheet
Dim strDateiname As String
Dim intA As Integer
Dim loEndRow As Long

For intA = 1 To worksheets.count

loEndRow = Worksheets("Auswertung").Cells(Rows.Count, 1).End(xlUp).Row + 1
If intA <10 then
Set wks = worksheets("sonder000" & (intA) & ".xls")
else
Set wks = worksheets("sonder00" & (intA) & ".xls")
end if

cells(loEndRow,1)=wks.range("C3")
cells(loEndRow,2)=wks.range("C6")
cells(loEndRow,3)=wks.range("A9")
cells(loEndRow,4)=wks.range("B10")
cells(loEndRow,5)=wks.range("D11")


Next

End Sub

djell
26.04.2009, 21:32
Hallo Case_Germany
Vielen Dank hat mir schon sehr geholfen!!!!!

Heika
04.10.2017, 15:26
Hallo zusammen,
das Makro von Case
vom 26.04.2009
funktioniert toll und
ich habe eine Frage wie ich das modifizieren kann.

Die Tabelle, in der alle ausgelesenen Zeilen eingefügt werden sollen, hat bereits eine Summenformel in der letzten Zeile.

Vorteil: immer wenn ich zwischen der 1. und dieser letzten Zeile was einfüge, summiert sich der Wert automatisch auf, weil der definierte Zeilenbereich der Summenformel immer angepaßt wird. Heißt, was zunächst Summe(B2:B4)war wird nach einfügen einer Zeile zu
Summe(B2:B5) und mit noch einer eingefügten Zeile zu
Summe(B2:B6) usw.

Ich versuchte meine Idee anzupassen an dieser Stelle des Makros
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1

aber dazu bin ich zu unbeholfen.
Ich versuchte z.B. was mit

Cells(Cells.Rows.Count, 6).End(xlUp).Offset(-1, 0).Select
ActiveCell.EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Kann wer helfen?
Dankeschön