AW: VBA Import bestimmter Mitarbeiter
08.01.2015 13:30:24
Klaus
Bitte mehr Mühe geben, immerhin willst DU Hilfe erhalten!
Dein Makro und deine Musterdateien passen nicht überein. Ein Sheets("AHT Rohdaten") gibt es nicht. Doppelte Mitarbeiter gibt es nicht. Das einzige Team in den Rohdaten ist "Markus". Usernamen sind nicht doppelt (einmal MITARBEITER1, einmal USER1 - schlampig anonymisiert). Die Datenstruktur von "Mitarbeiter2015.xlsx" ist nicht klar.
Im ersten Eintrag willst du nur nach Namen suchen, im zweiten Beitrag plötzlich nach Kalenderwochen. Wie und wo diese stehen, muss der Helfer erraten?
Ich poste dir mal ein Makro, dass alle "Markus-Team" Einträge der Rohdaten in Tabelle2 deines Blatts einfügt, unterhalb eventuell schon vorhandener Einträge, und dann Duplikate löscht.
Den Autofilter kannst du ausweiten und ihn nach Namen UND Kalenderwoche suchen lassen, ebenso musst du alles andere selber an deine "richtige" Datei anpassen. Selbst Schuld!
Sub DatenEinlesen()
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim lRowLast As Long
Dim lRowMA As Long
Set wkbOld = ActiveWorkbook
Call FileCheckOpen("\\C:\Users\Administrator\Desktop", "AHT_Rohdaten.xlsx")
Set wkbNew = ActiveWorkbook
With Sheets("RD CD") '.Columns("A:AS").Copy
lRowLast = .Cells(.Rows.Count, 1).End(xlUp).Row
If .AutoFilterMode Then .Cells.AutoFilter 'Turns OFF Autofilter, if any
.Range(.Cells(1, 29), .Cells(lRowLast, 29)).AutoFilter
.Range("$AC$1:$AC$1").AutoFilter Field:=1, Criteria1:="Markus"
.Range("A2:AC" & lRowLast).SpecialCells(xlCellTypeVisible).Copy
End With
wkbOld.Activate
'Sheets("AHT Rohdaten").ClearContents
With Sheets("AHT Rohdaten")
lRowMA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & lRowMA).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
lRowMA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
'die SPALTEN zum Remove-Duplicate Befehl kannst du selber anpassen!
.Range("$A$1:$AS$" & lRowMA).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6 _
, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, _
29, 30, 31, 32, 33, _
34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45), Header:=xlYes
End With
wkbNew.Close False
End Sub
Sub FileCheckOpen(sPath As String, sFile As String)
sPath = sPath & "/" & sFile
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sFile).Activate
End If
End Sub
Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function
Function WksSheetExists(sSheet As String) As Boolean
Dim wks As Object
On Error Resume Next
Set wks = Sheets(sSheet)
If Not wks Is Nothing Then
WksSheetExists = True
End If
On Error GoTo 0
End Function
Grüße,
Klaus M.vdT.