Codes verknüpfen
18.06.2021 13:35:37
kk86
ich habe euch unten meinen bestehenden Code angefügt.
Hier würde ich gerne die folgenden Befehle für das zweite Tabellenblatt ergänzen.
Private Sub Datei_verarbeiten()
Dim rQ, rZ
With wbQ.Worksheets("Tabelle2")
For rQ = 13 To .Range("A9999").End(xlUp).Row
rZ = wsZ.Range("A9999").End(xlUp).Row + 1
wsZ.Cells(rZ, 1) = wbQ.Name
wsZ.Cells(rZ, 2) = .Cells(rQ, 3)
wsZ.Cells(rZ, 3) = .Cells(rQ, 15)
wsZ.Cells(rZ, 4) = .Cells(rQ, 16)
wsZ.Cells(rZ, 5) = .Cells(rQ, 17)
Next
End With
End Sub
Könnte mir hier bitte jemand weiterhelfen?
Danke euch und schönes Wochenende
Bisheriger Code:
Dim RowCounter As Integer
Sub KalkulationLaden()
Dim ordner As FileDialog, Pfad As String
Dim strDatei As String, strPfad As String, strTyp As String
Dim wbX As Workbook, wksX As Worksheet, wksN As Worksheet
Application.ScreenUpdating = False
MsgBox "Ordner wählen in dem sich die Kalkulationen befinden"
Set ordner = Application.FileDialog(msoFileDialogFolderPicker) '4
If ordner.Show = -1 Then
Pfad = ordner.SelectedItems(1)
End If
strPfad = Pfad
strTyp = "xls"
Set wksN = ThisWorkbook.Sheets(1)
strDatei = Dir(strPfad & "\*." & strTyp)
Dim i As Integer
If RowCounter = 0 Then
i = 6
Else
i = RowCounter
End If
strDatei = Dir(strPfad & "\*." & strTyp)
Do Until strDatei = ""
Set wbX = Workbooks.Open(strPfad & "\" & strDatei)
Set wksX = wbX.Sheets(1)
wksN.Cells(6, i) = wksX.Cells(5, 9)
wksN.Cells(7, i) = wksX.Cells(5, 13)
i = i + 1
RowCounter = i
wbX.Close False
strDatei = Dir
Loop
Range("E6:E7").Select
Selection.Copy
Range(wksN.Cells(6, 6), wksN.Cells(7, i - 1)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("G1").Select
Selection.Copy
Range(wksN.Cells(6, i), wksN.Cells(7, 2000)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Dim Zelle As Range
Dim rngSpalte As Range
Set rngSpalte = Range("F7:ZZ7")
For Each Zelle In rngSpalte
If Zelle = "" Then Exit For
ActiveSheet.Hyperlinks.add Anchor:=Zelle, Address:=Zelle.Value, _
TextToDisplay:="Hier klicken"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next
Application.ScreenUpdating = True
End Sub
