Supportnet / Forum / Tabellenkalkulation
verschiedene daten untereinder ausgeben
Frage
Hallo Excelperten,
Ich suche in einem Laufwerk nach verschiedenen excel dateien und kopiere mir aus den mappen manche zellen das tue ich immer für eine produktgruppe
nun möchte ich das alle produktgruppen untereinander in der aktuellen tabelle erscheinen
aber die anzahl der einzelnen mappen ist mir nie so klar
wie schaffe ich es trotzdem ein makro zu schreiben das die Produktgruppen untereinander in meiner aktuellen tabelle erscheinen lässt.
ich hoffe mein problem ist klar geworden
hier mein makro das ich bis her verwende um die datei zu suchen und zellen zu kopieren
schön ist es nett aber es lief
als i tüpfelchen müsste ich noch die summe der spalte AL ausgeben
Sub klasse()
Worksheets("DataSheet").Unprotect (3333)
Worksheets("DataSheet").Activate
Worksheets("DataSheet").Range("B1").Select
Worksheets("DataSheet").Unprotect (3333)
Worksheets("DataSheet").Activate
Worksheets("DataSheet").Range("B1").Select
'Löschen
'Bereiche festlegen
Dim r1, r2, r3, r4, r5, r6, r7, r8
Set r1 = Worksheets("DataSheet").Range("B31:J999")
Set r2 = Worksheets("DataSheet").Range("M31:R999")
Set r3 = Worksheets("DataSheet").Range("U31:U999")
Set r4 = Worksheets("DataSheet").Range("Y31:Z999")
Set r5 = Worksheets("DataSheet").Range("AB31:AG999")
Set r6 = Worksheets("DataSheet").Range("AL31:AM999")
Set r7 = Worksheets("DataSheet").Range("AO31:AO999")
Set r8 = Worksheets("DataSheet").Range("A31:A999")
'Bereiche löschen
r1.ClearContents
r2.ClearContents
r3.ClearContents
r4.ClearContents
r5.ClearContents
r6.ClearContents
r7.ClearContents
r8.ClearContents
'PFR-Dateien nach der Produktgruppe AC durchsuchen
Set dateiSuche = Application.FileSearch
With dateiSuche
.LookIn = "P:\PSR\In_Bearbeitung\"
.FileName = "AC"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
'Meldung über Dateisuche und Fortgang oder Abbruch des Auftrags
Meldung = "" & .foundfiles.count & " AC file(s) found."
Antwort = MsgBox(Meldung, [1])
If Antwort = vbOK Then
Else
End If
Dim countff As Integer
countff = .foundfiles.count
'Pfad in die Datei schreiben
For b = 1 To countff
'Produkt Gruppe
Worksheets("DataSheet").Cells(b + 30, 4).Value = "" & .foundfiles(b) & _
"Product Management'!$c$2"
'Customer
Worksheets("DataSheet").Cells(b + 30, 8).Value = "" & .foundfiles(b) & _
"Product Management'!$c$1"
'R&D Account/Number
Worksheets("DataSheet").Cells(b + 30, 5).Value = "" & .foundfiles(b) & _
"Product Management'!$c$3"
'Projekt name
Worksheets("DataSheet").Cells(b + 30, 7).Value = "" & .foundfiles(b) & _
"Project Page'!$AB$4"
'Projekt Manager
Worksheets("DataSheet").Cells(b + 30, 10).Value = "" & .foundfiles(b) & _
"Product Management'!$R$2"
'SOP (Target)
Worksheets("DataSheet").Cells(b + 30, 14).Value = "" & .foundfiles(b) & _
"Product Management'!$M$36"
'Price/Unite (Target)
Worksheets("DataSheet").Cells(b + 30, 15).Value = "" & .foundfiles(b) & _
"Calculation'!$D$71"
'Total number of units over lifetime (Target)
Worksheets("DataSheet").Cells(b + 30, 16).Value = "" & .foundfiles(b) & _
"Calculation'!$B$69"
'Lifetime (Target)
Worksheets("DataSheet").Cells(b + 30, 17).Value = "" & .foundfiles(b) & _
"Product Management'!$M$39"
'Total costs/ unit (Target)
Worksheets("DataSheet").Cells(b + 30, 18).Value = "" & .foundfiles(b) & _
"Calculation'!$E$71"
'R&D gross (Target)
Worksheets("DataSheet").Cells(b + 30, 25).Value = "" & .foundfiles(b) & _
"Calculation'!$I$69"
'Payments total (Target)
Worksheets("DataSheet").Cells(b + 30, 26).Value = "" & .foundfiles(b) & _
"Calculation'!$N$69"
'Payback periode (Target)
Worksheets("DataSheet").Cells(b + 30, 28).Value = "" & .foundfiles(b) & _
"Product Management'!$M$38"
'SOP (Actual)
Worksheets("DataSheet").Cells(b + 30, 29).Value = "" & .foundfiles(b) & _
"Product Management'!$N$36"
'Price/unit (Actual)
Worksheets("DataSheet").Cells(b + 30, 30).Value = "" & .foundfiles(b) & _
"Calculation'!$D$111"
'Total number of units over lifetime (Actual)
Worksheets("DataSheet").Cells(b + 30, 31).Value = "" & .foundfiles(b) & _
"Calculation'!$B$109"
'Lifetime (Actual)
Worksheets("DataSheet").Cells(b + 30, 32).Value = "" & .foundfiles(b) & _
"Product Management'!$N$39"
'Total costs/ unit (Actual)
Worksheets("DataSheet").Cells(b + 30, 33).Value = "" & .foundfiles(b) & _
"Calculation'!$E$111"
'R&D gross (Actual)
Worksheets("DataSheet").Cells(b + 30, 38).Value = "" & .foundfiles(b) & _
"Calculation'!$I$109"
'Payments total (Actual)
Worksheets("DataSheet").Cells(b + 30, 39).Value = "" & .foundfiles(b) & _
"Calculation'!$N$109"
'Payback periode (Actual)
Worksheets("DataSheet").Cells(b + 30, 41).Value = "" & .foundfiles(b) & _
"Product Management'!$N$38"
Next b
'Keine Dateien gefunden
Else
MsgBox "AC files not found."
End If
End With
`Leerzeille für die Summe
Worksheets("DataSheet").Cells(b + 30, 1).Value = "SUM"
foracvcount = b - 1
b = b + 1
Worksheets("DataSheet").Activate
Worksheets("DataSheet").Range("B31:AO999").Select
Selection.Replace What:="\PSR_RD", Replacement:="\[PSR_RD", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="xls", Replacement:="xls]", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="P:", Replacement:="='P:", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
'Test = Summen Berechnung für Spalte Al
count = 0
For b = i + 1 To foracvcount
count = count + Worksheets("DataSheet").Cells(b + 30, 38).Value
Next b
Worksheets("DataSheet").Cells(b + 30, 38).Value = count
End Sub