Werte autom. in neue Liste übergeben

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Andreas,
dann wird Zeit für die erste Stufe: Makro Rekorder.
Du machst es sichtbar, in dem Du den Menüpunkt "Entwicklertools" sichtbar macht (Rechtsklick auf Menü, Menüband anpassen ...)
Dort ist der Makro Rekorder, steht hinter "Makro aufzeichen": drauf drücken, machen, aufzeichnung stoppen, Code anschauen.
Achtung: nicht 20 Aktionen aufnehmen, sondern nur 1 oder 2. Das aufgenommen Code ist meist ausführlich und Du kannst nicht mehr den Zuammenhang zwischen Aktion und Code machen.
Du willst die Zelle C22:C28 markieren, kopieren, irgendwo ander pasten? Aufzeichnung starten, machen, stoppen, Code anschauen.
Du willst die Datei mit einem neuen Namen speichern? Aufzeichnung starten, machen, stoppen, Code anschauen.
Dann musst Du noch rausfinden, wie man die Wert einer Zelle auslist, eine Variable ändert und das alles in einer Ereignis-Prozedur "Worksheet_Change": Das gleich wie bei "DieseArbeitsmappe" aber auf dem betroffenen Blatt doppelklicken.
Sieht dann so aus:


Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C1")) Is Nothing Then
'...Dein Code hier
End If
End Sub

Viel Erfolg
Yal

Dim sSF_Name$, sFrage$, sZielOrdner$ Public Const sKey = "" Const sPfadErledigt As String = "C:\Users\andreas\Desktop\Test neu\" Sub SpeichernIn() Dim sPfad$ On Error Resume Next 'Nur SaveAs kann eine Fehler verursachen. Da danach nichts ist, ist "Next" = Ende sPfad = sPfadErledigt & "K " & Worksheets("Tabelle1").Range("C1") & ".xlsm" ActiveWorkbook.SaveAs Filename:=sPfad, FileFormat:=xlOpenXMLWorkbookMacroEnabled End Sub Private Sub CommandButton1_Click() Dim letzte As Long 'In Spalte 23 ("W") die erste freie Zelle von unten kommend ermitteln With Worksheets("Übersicht") letzte = .Cells(Rows.Count, 23).End(xlUp).Row + 1 .Cells(letzte, 2).Resize(1, 4) = Application.Transpose(Range("F23:L23").Value) End With End Sub Sub Übertragen() ' Übertragen Makro ThisWorkbook.Worksheets("Tabelle1").Range("F23:L23").Copy Workbooks("Übersicht.xlsx").Worksheets("Übersicht").Range("A2").PasteSpecial _ Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ' Windows("K 100333.xlsm").Activate End Sub

Hallo Andreas,
dann so:


'unter Anbindung von Bibliothek "Microsoft Scripting Runtime":
'Extras, Verweise..., Hacken bei "Microsoft Scripting Runtime"
Dim FSO As New FileSystemObject
Const sPfadErledigt As String = "C:\Users\andreas\Desktop\Test neu\"
Const DateinamenMuster = " K xxx.xlsm"
Private Sub CommandButton1_Click()
Dim Datei As File
'1. Prüfen, dass der Pfad gültig ist
'2. Prüfen, ob Dateinumemr gültig ist
'3. Prüfen ob Datei bereit existiert
'4. Daten übertragen
'5. Datein Speichern
'1.
If Pfad_prüfen(sPfadErledigt) Is Nothing Then
MsgBox "Verzeichnis """ & sPfadErledigt & """ nichtvorhadne oder nicht gefunden.", vbExclamation
Exit Sub
End If
'2.
If Worksheets("Tabelle1").Range("C1").Value = "" Or Not IsNumeric(Worksheets("Tabelle1").Range("C1").Value) Then
MsgBox "Nummer """ & Worksheets("Tabelle1").Range("C1").Value & """ ist für diese Datei nicht gültig.", vbExclamation
Exit Sub
End If
'3
Set Datei = Datei_prüfen(sPfadErledigt & Replace(DateinamenMuster, "xxx", Worksheets("Tabelle1").Range("C1").Value))
If Not Datei Is Nothing Then
If MsgBox("Datei """ & Datei.ShortPath & """ existiert bereits. " & vbCr & vbCr & "Überschreiben?", vbYesNo + vbQuestion)  vbYes Then
Exit Sub
End If
End If
'4.
ThisWorkbook.Worksheets("Tabelle1").Range("F23:L23").Copy
Workbooks("Übersicht.xlsx").Worksheets("Übersicht").Range("A2").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'5.
ThisWorkbook.SaveAs Datei.Path, xlOpenXMLWorkbookMacroEnabled
'    ThisWorkbook.Close
End Sub
Function Pfad_prüfen(Pfad As String) As Folder
'gibt einen Folder-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Pfad_prüfen = FSO.GetFolder(Pfad)
End Function
Function Datei_prüfen(Pfad As String) As File
'gibt einen File-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Datei_prüfen = FSO.GetFile(Pfad)
End Function

VG
Yal

Sub Übersichtöffnen() ' Übersichtöffnen Makro Range("E3").Select ActiveCell.FormulaR1C1 = "XXXXXXXX" 'Hab hier x reingemacht, weil die Eingabe verschieden sein kann Range("E4").Select ActiveWindow.SmallScroll Down:=-15 Windows("Vorlage.xlsm").Activate End Sub

Function IstWB_offen(WBTeilname As String) As Workbook Dim W As Workbook For Each W In Workbooks If InStr(1, W.Name, WBTeilname) Then Exit Function End If Next End Function Sub Test() Dim W As Workbook Set W = IstWB_offen("149") If Not W Is Nothing Then Debug.Print W.Name End Sub Sub Workbooks_auflisten() Dim W As Workbook For Each W In Workbooks Debug.Print W.Name Next End Sub

Beliebteste Forumthreads (12 Monate)

Werte autom. in neue Liste übergeben

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

256 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte autom. in neue Liste übergeben

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

256 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread