Einen aus einem bestimmte Bereich etwas

Dim wkbName As String, wkbNeu As String, wksName As String wkbName = ThisWorkbook.Name wksName = ActiveSheet.Name Workbooks.Add wkbNeu = ActiveWorkbook.Name Workbooks(wkbName).Sheets(wksName).Range("A2:I2000").Copy Workbooks(wkbNeu).Sheets(1).Range("A2") Dim pfad As String, DateiName As String 'pfad = Workbooks(wkbName).Sheets(wksName).Range("D9") pfad = Workbooks(wkbName).Sheets("Einstellungen").Range("D9") DateiName = Workbooks(wkbName).Sheets(wksName).Range("N34") 'Workbooks(wkbNeu).SaveAs Filename:=pfad & "H:\HOLZTool\03 Holzlisten\01 aus Rechenhilfe\" & DateiName & ".xlsx" Workbooks(wkbNeu).SaveAs Filename:=pfad & DateiName & ".xlsx" ActiveWorkbook.Close 'Löschen des Datei Namens Range("N34:P34").ClearContents Range("I3").Select

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo auch,
Je nach dem wie gut ich deine Erklärung verstanden habe, ergibt sich folgende Code:


Sub kopieren()
Dim wsZiel As Worksheet
Dim wsQuelle As Worksheet
Dim Pfad As String
Dim DateiName As String
Dim ZeilenListe
Dim i
'Daten in der Quelle suchen und sammlen (es werden nur die Zeilennummer gesammelt)
Set wsQuelle = ActiveSheet 'setzt voraus, dass man sich in der richtige Datenblatt befindet, wenn das Makro angestossen wird
ZeilenListe = Array() 'Dummy-Initialisierung (ergibt Ubound(..) = -1)
ZeilenListe = Daten_sammeln(wsQuelle, "I3:I2000", "BSH")
If UBound(ZeilenListe) = -1 Then
MsgBox "Es wurde keinen Treffer gefunden.", vbInformation, "Abbruch"
Exit Sub
End If
'neue Arbeitsmappe erzeugen
Workbooks.Add
Set wbZiel = ActiveWorkbook.Worksheets(1)
'Daten übertragen
Application.ScreenUpdating = False
For Each i In ZeilenListe
wsQuelle.Range("A" & i & ":I" & i).Copy wsZiel.Range("A99999").End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
'Speichername und Pfad finden
Pfad = Trim(ThisWorkbook.Sheets("Einstellungen").Range("D9"))
If Right(Pfad, 1)  "\" Then Pfad = Pfad & "\"
DateiName = Trim(wsQuelle.Range("N34"))
'Speichern und schliessen
wsZiel.Parent.SaveAs Filename:=Pfad & DateiName & ".xlsx"
wsZiel.Close
'Löschen des Dateinamens
wsQuelle.Range("N34:P34").ClearContents
wsQuelle.Range("I3").Select
End Sub
Private Function Daten_sammeln(ByVal Sh As Worksheet, Suchbereich As String, SuchString)
Dim Z As Range
Dim erg()
Dim ersteTreffer As String
'Dummy-Init. Damit ergibt UBound(erg) = -1 und das Increment Redim Preserve kann stattfinden
erg = Array()
'erste Suche. Könnte ins leer gehen
Set Z = Sh.Range(Suchbereich).Find(SuchString, LookAt:=xlPart, MachtCase:=False)
If Not Z Is Nothing Then
ersteTreffer = Z.Address
'alle Treffer finden
Do
ReDim Preserve erg(UBound(erg) + 1)
erg(UBound(erg)) = Z.Row
Set Z = Sh.Range(Suchbereich).Find
Loop While Z.Address  ersteTreffer
End If
'Ergebnisse übergeben
Daten_sammeln = erg
End Function

Es wird mit den Objekt selbst (Set wsQuell = ...) anstatt mit einem dessen Eigenschaften ( Worksheets(wksName) ). Es mach das Coding leichter.
Da Du keine Datei mitgeliefert hast, könnte ich das "Werk" nicht testen. Es steckt sicher viele Fehler drin.
Wegen deine begrenzte VBA-Kompetenz gehe ich nicht davon aus, dass die eventuell notwendige Korrekturen selber hinbekommst. Ich habe viele Kommentare hinzugefügt, falls irgendjemand irgendwann eine ähnliche Frage hat.
VG
Yal

Sub BSHspeichern() Dim wsZiel As Worksheet Dim wsQuelle As Worksheet Dim Pfad As String Dim DateiName As String Dim ZeilenListe Dim i 'Daten in der Quelle suchen und sammlen (es werden nur die Zeilennummer gesammelt) Set wsQuelle = ActiveSheet 'setzt voraus, dass man sich in der richtige Datenblatt befindet, wenn das Makro angestossen wird ZeilenListe = Array() 'Dummy-Initialisierung (ergibt Ubound(..) = -1) ZeilenListe = Daten_sammeln(wsQuelle, "I3:I2000", "BSH") If UBound(ZeilenListe) = -1 Then MsgBox "Es wurde keinen Treffer gefunden.", vbInformation, "Abbruch" Exit Sub End If 'neue Arbeitsmappe erzeugen Workbooks.Add Set wsZiel = ActiveWorkbook.Worksheets(1) 'Daten übertragen Application.ScreenUpdating = False For Each i In ZeilenListe wsQuelle.Range("A" & i & ":I" & i).Copy wsZiel.Range("A99999").End(xlUp).Offset(1, 0) Next Application.ScreenUpdating = True 'Speichername und Pfad finden Pfad = Trim(ThisWorkbook.Sheets("Einstellungen").Range("D9")) If Right(Pfad, 1) "\" Then Pfad = Pfad & "\" DateiName = Trim(wsQuelle.Range("N34")) 'Speichern und schliessen wsZiel.Parent.SaveAs Filename:=Pfad & DateiName & ".xlsx" wsZiel.Close 'Löschen des Dateinamens wsQuelle.Range("N34:P34").ClearContents wsQuelle.Range("I3").Select End Sub Private Function Daten_sammeln(ByVal Sh As Worksheet, Suchbereich As String, SuchString) Dim Z As Range Dim erg() Dim ersteTreffer As String 'Dummy-Init. Damit ergibt UBound(erg) = -1 und das Increment Redim Preserve kann stattfinden erg = Array() 'erste Suche. Könnte ins leer gehen Set Z = Sh.Range(Suchbereich).Find(SuchString, LookAt:=xlPart, MachtCase:=False) If Not Z Is Nothing Then ersteTreffer = Z.Address 'alle Treffer finden Do ReDim Preserve erg(UBound(erg) + 1) erg(UBound(erg)) = Z.Row Set Z = Sh.Range(Suchbereich).Find Loop While Z.Address ersteTreffer End If 'Ergebnisse übergeben Daten_sammeln = erg End Function

Beliebteste Forumthreads (12 Monate)

Einen aus einem bestimmte Bereich etwas

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread