VBA Code erweitern, nur bestimmte Werte aus Matrix kopieren
20.11.2024 17:53:26
AxelF1977
da ich hier so fantastische Hilfe bekommen habe, wende ich mich mit der letzten Hürde meines Umbaus der Tabelle noch einmal an Euch.
In dem Code unten werden alle Werte einer anderen Exceltabelle in die vorhandene geladen. Dann werden bestimmte Daten in ein anderen Tabellenblatt kopiert und die ersten Daten gelöscht.
Bisher mussten meine Kollegen immer die richtige Tabelle runter laden und diese dann "importieren". Das möchte ich ändern. Alle benötigten Werte, verschiedene Städte, sollen nun in einer Tabelle sein, und diese soll importiert werden.
Im Tabellenblatt "menu" steht in der Zelle "N4" der Name der Stadt, für welche die Daten kopiert werden sollen.
Nun sollen aus der zu importierenden Werte NUR die Zeilen der Matrix eingefügt werden mit unterem Code, die z.B. in Spalte Ab Berlin zu stehen haben.
In Spalte A stehen IMMER die Städtenamen.
Also sollte das Script unten nur so erweitert werden, das in Spalte A zuerst geschaut wird, wo überall eine Übereinstimmung mit der Zelle N4 im Menu Tabellenblatt besteht. Alle diese Zeilen sollen dann mit dem Script unten koipert werden.
Das Script läuft und ist ok, nur die Funktion des Aussortierens der nicht passenden Städte muss rein.
Sub Import_BEISPIEL_Data()
Dim wiMaster As Office.FileDialog
Dim SvName As String
Dim strInput As String
Dim strFile As String
Dim Pfad As String
Dim Datei As String
Dim wbRGdata As Workbook, wbMaster As Workbook
Dim wsRateshop As Worksheet, WsMaster As Worksheet
Dim firstline As Double
Dim tbl()
Dim varRegion, pvTab As PivotTable, pvField As PivotField
Dim varMG01
Dim strDir As String
varMG01 = ThisWorkbook.Sheets("menu").Range("N4").Value
Set wbMaster = ThisWorkbook
Set WsMaster = wbMaster.Sheets("Import BEISPIEL")
Pfad = "C:\Users\" & Environ("Username") & "\Documents\...\" & Format(Now, "yyyy") & "\BEISPIEL\" & Format(Now, "mm") & " " & Format(Now, "mmmm") & " " & Format(Now, "yyyy") & "\" & Format(Now, "dd.mm") & " " & "Lokal" & "\" & "BEISPIEL" & "\"
Datei = "BEISPIEL_" & Format(Now, "yyyymmdd")
strFile = Dir(Pfad & "*" & Datei & "*.xlsx")
Set wbRGdata = Workbooks.Open(Pfad & strFile)
Set wsRateshop = ActiveSheet
'copy data
With wsRateshop
tbl = .Range("A1:BZ30000").Value2
End With
'copy on top
With WsMaster
firstline = .Cells(.Rows.Count, 1).End(xlUp).Row + 0
.Cells(firstline, 1).Resize(UBound(tbl), UBound(tbl, 2)) = tbl
End With
'Namen der Datei einfügen
Dim strFileName01 As String
strFileName01 = Format(Now, "dd.mm.yyyy hh:mm")
wbMaster.Sheets("menu").Range("A6").Value = strFileName01
'Namen der Datei einfügen
Dim strFileName02 As String
strFileName02 = Mid(strFile, InStrRev(strFile, "\", , vbTextCompare) + 1)
wbMaster.Sheets("menu").Range("E4").Value = strFileName02
'close import file
wbRGdata.Close (False)
Dim raFund As Range, loLetzte As Long, i As Long
Dim wsZ As Worksheet, wsQ As Worksheet, strSuchbegriff As String
Set wsZ = ThisWorkbook.Worksheets("data BEISPIEL")
Set wsQ = ThisWorkbook.Worksheets("Import BEISPIEL")
Application.ScreenUpdating = False
With wsZ
'vorhandene Daten im Blatt 2 löschen
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
If loLetzte > 1 Then
.Range(.Cells(2, 1), .Cells(loLetzte, 16)).ClearContents
End If
'Schleife über die Überschriften im Blatt 2
For i = 1 To 16
strSuchbegriff = .Cells(1, i)
'entspr. Überschrift im Blatt 3 suchen
With wsQ
Set raFund = .Rows("1:1").Find(What:=strSuchbegriff, LookIn:=xlValues, LookAt:= _
xlWhole)
'wenn gefunden Daten kopieren
If Not raFund Is Nothing Then
loLetzte = .Cells(.Rows.Count, raFund.Column).End(xlUp).Row
.Range(.Cells(2, raFund.Column), .Cells(loLetzte, raFund.Column)).Copy
End If
End With
'im Blatt 2 in die entspr. Spalte einfügen
.Cells(2, i).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Next i
End With
Set wsZ = Nothing: Set wsQ = Nothing
Application.ScreenUpdating = True
Worksheets("Import BEISPIEL").Range("A2:NTP100000").ClearContents
MsgBox ("Import data and saving successful")
End Sub
Anzeige