Hallo Allemaal,
Voor een project ben ik bezig met dataverwerking, deze data wordt aangemaakt in een excel bestand die onder een tijdcode (helaas is dit niet aan te passen) word weggezet in een map.
Voor de duidelijkheid, zo ziet de bestandindeling eruit
Productnaam map
---> Datamatrixcode map
---> Excel bestand
Nu mijn vraag:
Ik ben opzoek naar een macro, waarbij ik de productnaam map kan selecteren, de macro automatisch de specifieke data (bv A87;F167) uit alle excel bestanden kopieerd en onder elkaar weg schrijft in 1 excel bestand.
Extra vraag:
Is het mogelijk om de bestanden die reeds zijn gekopieerd automatisch ergens anders naartoe te verplaatsen zodat de bestanden niet nogmaals meegenomen worden indien ik nieuwe data wil importeren?
Wat heb ik tot nu toe?
Om mijn werk iets simpeler te maken heb ik tot nu toe een macro gebruikt waar ik het excel bestand selecteer en hij automatisch de data eruit haalt, het grote nadeel is dat ik dan nog steeds honderde keren ik moet gaan klikken.
Sub InhoudKopieren()
Dim sh1b As Object
Dim sh1a As Object
Dim sh2a As Object
Dim sh2b As Object
Dim sh3a As Object
Dim sh3b As Object
Dim oBoek1 As Object
Dim oBoek2 As Object
Dim objBs As Variant
Dim fDialoog As FileDialog
Dim sBestandsnaam As String
Dim sNaam As String
Dim sPad As String
'Stel het werkboek en het pad in.
Set oBoek1 = ThisWorkbook
sPad = oBoek1.Path
'Pas het fiiledialoog aan en open het
Set fDialoog = Application.FileDialog(msoFileDialogOpen)
With fDialoog
.Title = "Selecteer het te kopiëren Werboek"
.ButtonName = "Kopieer bord"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "1. Excel 2010", "*.xlsm"
.Filters.Add "2. Excel 2003", "*.xls"
.InitialView = msoFileDialogViewDetails
.InitialFileName = sPad
.Show
'Haal bestandsnaam op.
For Each objBs In .SelectedItems
sBestandsnaam = objBs
Next objBs
End With
'Juist bestand geslecteerd?
If sBestandsnaam = "" Then
MsgBox "Er is geen bestand geselecteerd"
GoTo ResetAlles
End If
sNaam = Strings.Mid(sBestandsnaam, InStrRev(sBestandsnaam, "\") + 1)
If sBestandsnaam = oBoek1.Name Then
MsgBox "Wijzig eerst de naam van het bestand" & vbLf & _
"Start dan de kopieer routine opnieuw."
GoTo ResetAlles
End If
If Strings.InStr(1, Strings.UCase(sBestandsnaam), "xls", 1) = 0 Then
MsgBox "Onbekend bestand: " & sNaam & vbLf & vbLf _
& "Het geselecteerde bestand wordt niet herkend als Excel Werkboek" & vbLf _
& "Start de kopieer routine opnieuw en selecteer het juiste bestand." & vbLf _
GoTo ResetAlles
End If
On Error GoTo Fout
'klaarmaken voor kopiëeren
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'open het werkboek
Workbooks.Open sBestandsnaam
'kopieer
Set oBoek2 = ActiveWorkbook
Set sh1a = oBoek1.Worksheets(1)
Set sh1b = oBoek2.Worksheets(1)
Set sh2a = oBoek1.Worksheets(2)
Set sh2b = oBoek2.Worksheets(3)
Set sh3a = oBoek1.Worksheets(3)
Set sh3b = oBoek2.Worksheets(3)
sh1b.Range("a87", "f169").Copy
sh1a.Range("a2").PasteSpecial Paste:=xlPasteValues
'Sluit het bronbestand en ga naar het eerste blad
oBoek2.Close
sh1a.Activate
sh1a.Cells(5, 2).Select
'Zet alles weer op 0
ResetAlles:
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
Set sh1a = Nothing
Set sh1b = Nothing
Set sh2a = Nothing
Set sh2b = Nothing
Set sh3a = Nothing
Set sh3b = Nothing
Set oBoek1 = Nothing
Set oBoek2 = Nothing
Set fDialoog = Nothing
On Error GoTo 0
Exit Sub
' foutafhandeling ------------------------------------
Fout:
MsgBox "Kopieerfout:" & vbLf _
& "Het geselcteerde bestand wordt" & vbLf _
& "niet herkend als factbord." & vbLf _
& "Start de kopieer routine opnieuw" & vbLf _
& "en selecteer het juiste bestand."
Unload UfWacht
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Zijn dit soort macro's mogelijk (ik zit zelf nog heel erg in de kinderschoenen namelijk...)
Hopelijk kunnen jullie mij hiermee helpen, indien er nog vragen zijn hoor ik ze graag.
