VBA Programierung

Hallo Leute
Ich benötige mal wieder Hilfe.
Ich benötige ein Macro für die schon vorh. Tabelle (Preisakt_Start.xls, übrigens auch aus diesem Forum) mit folgender Funktion:
Wenn die Tabelle über den Startbutten die Funktion Auslesen des Verzeichnisses einschließlich Unterverzeichnisse abgeschlossen hat (Tabelle sieht dann ungefähr so wie in Preisakt_Start.xls, E_Preislisten, aus) möchte ich ein Macro ausführen lassen, welches zuerst den 1 Wert der jeweiligen Tabelle ausließt, mit einem Wert (z. B. Wert 1 x 1,1 multipliziert um 10 % Aufschlag zu berechnen), diesen dann in die Tabelle unter dem jeweiligen Pfad einträgt, danach das Gleiche mit dem letzten Wert (siehe Preisakt_ZSCHR.xls), und so weiter, bis zum Ende der Preisakt_Start.xls, E_Preislisten).
Danach soll das Marco die Pfadangaben kürzen (siehe Preisakt_End.xls).
Datein sind unter https://www.herber.de/bbs/user/80563.zip
Ich hoffe das alles gut beschrieben zu haben und das jemand helfen kann.
Ich hatte diese Anfrage heute schon mal eingestellt aber leuder den Anhang vergessen.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Daten_einlesen() Dim varWert_1, varWert_2 Dim strDatei As String Dim Zeile As Long Dim wksZiel As Worksheet Dim wkbQ As Workbook, wksQ As Worksheet Set wksZiel = ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count) Application.ScreenUpdating = False With wksZiel For Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 To 3 Step -1 strDatei = .Cells(Zeile - 1, 1).Value Set wkbQ = Application.Workbooks.Open(Filename:=strDatei, ReadOnly:=True) Set wksQ = wkbQ.Worksheets(1) With wksQ varWert_1 = .Cells(1, 1).Value varWert_2 = .Cells(.Rows.Count, 1).End(xlUp).Value End With wkbQ.Close savechanges:=False Set wkbQ = Nothing Set wksQ = Nothing .Range(.Rows(Zeile), .Rows(Zeile + 1)).Insert .Cells(Zeile - 1, 1) = Mid(strDatei, 28) .Cells(Zeile, 1) = varWert_1 .Cells(Zeile + 1, 1) = varWert_2 Next End With Application.ScreenUpdating = True End Sub

Hallo Achim,
die Letzte Zeile dürfte ja passen.
Für die 1. Zeile lasse ich das Makro jetzt nach "Auflage" suchen und nehme die Zeile darunter.
Gruß
Franz

Sub Daten_einlesen2()
Dim varWert_1, varWert_2
Dim strDatei As String
Dim Zeile As Long, Zeile_QL As Long, Zeile_Q1 As Long, ZelleAuflage As Range
Dim wksZiel As Worksheet
Dim wkbQ As Workbook, wksQ As Worksheet
Set wksZiel = ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
Application.ScreenUpdating = False
With wksZiel
For Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 To 3 Step -1
strDatei = .Cells(Zeile - 1, 1).Value
Set wkbQ = Application.Workbooks.Open(Filename:=strDatei, ReadOnly:=True)
Set wksQ = wkbQ.Worksheets(1)
With wksQ
'Letzte Zeile in Quelltabelle
Zeile_QL = .Cells(.Rows.Count, 1).End(xlUp).Row
'Zelle mit "Auflage" suchen in Spalte 1
Set ZelleAuflage = .Range(.Cells(1, 1), .Cells(Zeile_QL, 1)).Find _
(what:="Auflage", LookIn:=xlValues, Lookat:=xlWhole)
If ZelleAuflage Is Nothing Then
Zeile_Q1 = 0
Else
Zeile_Q1 = .Cells(Zeile_QL, 1).End(xlUp).Row + 1
End If
'Wert unterhalb von Auflage
If Zeile_Q1 = 0 Then
varWert_1 = "Zelle mit ""Auflage"" nicht gefunden!"
Else
varWert_1 = .Cells(Zeile_Q1, 1).Value
End If
'Wert in letzter Zeile
varWert_2 = .Cells(Zeile_QL, 1).Value
End With
wkbQ.Close savechanges:=False
Set wkbQ = Nothing
Set wksQ = Nothing
.Range(.Rows(Zeile), .Rows(Zeile + 1)).Insert
.Cells(Zeile - 1, 1) = Mid(strDatei, 28)
.Cells(Zeile, 1) = varWert_1
.Cells(Zeile + 1, 1) = varWert_2
Next
End With
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread