Zellen in variabler Zeile von Quelle übertragen

Hallo Freunde vom Herbers Excel Forum,
ich habe mal wieder ein Nuß zu knacken, wo ich keine Scripte finde.
In einer Quelldatei stehen Daten in einer Zeile. Die Aufgabe besteht darin, die Zeilen zu finden welche in Spalte A ein x haben, und bestimmte Zellinhalte in eine neue Datei (Master) zu verschieben. lngZeile ist dabei die variable Zeile
im Master = lngZeile die Zeile welche am Beginn ein x in Spalte A hat
in der Quelle = lngZeile2 die erste freie Zeile
Dabei sollte dann folgendes kopiert werden:
Quelle (lngZeile,3) nach Master (lngZeile2,2)
Quelle (lngZeile,4) nach Master (lngZeile2,3)
Quelle (lngZeile,5) nach Master (lngZeile2,4)
Quelle (lngZeile,7) nach Master (lngZeile2,6)
Quelle (lngZeile,10) nach Master (lngZeile2,9)
Quelle (lngZeile,12) nach Master (lngZeile2,11)
Quelle (lngZeile,13) nach Master (lngZeile2,12)
Quelle (lngZeile,14) nach Master (lngZeile2,13)
Master liegt auf einem Netzlaufwerk, und müsste grüft werden ob es im Schreibzugriff von anderen ist (also bereits geöffnet)
Quelle liegt ebenso auf einem Netzlaufwerk. Da hier aber nicht geschrieben wird, ist es m.W nicht notwendig zu rpüfen.
Der Dateiname von "Master" ist als Variable in einem Feld Tabelle "Paramater" in der Quelle auszulesen. Dies dient dazu, um das Script später einfach anzupassen wenn jemand die Tabelle "Master" neu benennt.
Wer hat zeit und Lust beim knacken der Nuß zu helfen.
Vielen Dank an alle Forumsmitglieder :-))))))))
Master Beispiel: https://www.herber.de/bbs/user/116575.xlsx
Quelle Beispiel: https://www.herber.de/bbs/user/116573.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Christian
Ungewöhnlich, dass du von der Quelle aus startest.

Sub t()
Dim wkbQuelle As Workbook, wkbMaster As Workbook
Dim wksQuelle As Worksheet, wksMaster As Worksheet
Dim strMaster As String, lngZeile As Long
Set wkbQuelle = ThisWorkbook
Set wksQuelle = wkbQuelle.Worksheets("Tabelle1")
strMaster = ThisWorkbook.Path & "\Master.xlsx"
'strMaster = "C:\Pfad\" & wkbQuelle.Worksheets("Parameter").Range("A1") & ".xlsx" ' Alternative
If IsFileOpen(strMaster) Then
MsgBox "Datei geöffnet, Abbruch"
Exit Sub
End If
Set wkbMaster = Workbooks.Open(strMaster)
Set wksMaster = wkbMaster.Worksheets("Tabelle1")
With wksQuelle
For lngZeile = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(lngZeile, 1) = "x" Then
.Range(.Cells(lngZeile, 2), .Cells(lngZeile, 13)).Copy _
wksMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next lngZeile
End With
wkbMaster.Close True
End Sub

' Quelle: support.microsoft.com/de-de/help/291295/macro-code-to-check-whether-a-file-is-already-open

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
On Error Resume Next   ' Turn error checking off.
filenum = FreeFile()   ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum          ' Close the file.
errnum = Err           ' Save the error number that occurred.
On Error GoTo 0        ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function

cu
Chris

Sub t() Dim wkbQuelle As Workbook, wkbMaster As Workbook Dim wksQuelle As Worksheet, wksMaster As Worksheet Dim strMaster As String, lngZeile As Long, lngLetzte As Long Set wkbQuelle = ThisWorkbook Set wksQuelle = wkbQuelle.Worksheets("Tabelle1") strMaster = ThisWorkbook.Path & "\Master.xlsx" 'strMaster = "C:\Pfad\" & wkbQuelle.Worksheets("Parameter").Range("A1") & ".xlsx" ' Alternative If IsFileOpen(strMaster) Then MsgBox "Datei geöffnet, Abbruch" Exit Sub End If Set wkbMaster = Workbooks.Open(strMaster) Set wksMaster = wkbMaster.Worksheets("Tabelle1") With wksQuelle For lngZeile = 1 To .Cells(Rows.Count, 1).End(xlUp).Row If .Cells(lngZeile, 1) = "x" Then lngLetzte = wksMaster.Cells(Rows.Count, 1).End(xlUp).Row + 1 .Cells(lngZeile, 2).Copy wksMaster.Cells(lngLetzte, 1) 'hier ergänzen End If Next lngZeile End With wkbMaster.Close True End Sub

Beliebteste Forumthreads (12 Monate)

Zellen in variabler Zeile von Quelle übertragen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen in variabler Zeile von Quelle übertragen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread