• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Macro of VBA script automatiseren

Status
Niet open voor verdere reacties.
D

Dappre

Gebruiker
Lid geworden
28 mei 2017
Berichten
102
Hi forumleden,

Ik zit met een vraagstuk waar ik niet aan uit kom aangezien mijn Excel kennis dermate is dat ik hier geen slimme en passende oplossing voor weet te vinden.

Het volgende moet ik wekelijks uitvoeren:

- een Excel export met data waarbij ca. 30 genruikers hun aanvullingen doen op facturen met "Ja" en "Nee". Dit komt natuurlijk zoals altijd terug in 100 verschillende vormen.

Nu heb ik een macro die alle bestanden samenvoegt tot 1 worksheet. Nadeel hiervan is dat de file gigantisch groot wordt en met 1000 lege velden. Deze dien ik handmatig te verwijderen om er vervolgens 1 worksheet van te maken die voorzien is van de juiste indeling. Het gaat in de meeste gevallen om 3 kolommen. Ook dit wil wel eens afwijken in enkele gevallen waardoor het altijd knippen en plakken word.

Wie kan mij in de juiste richting helpen door dit proces juist en efficiënt in te richten. Dit werk kost me wekelijks 2 dagen om een uiteindelijke rapportage te kunnen ontwikkelen. Helaas zijn gebruikers op dermate niveau dat ik het aan de voorkant niet kan tackelen.

Alvast bedankt voor jullie inbreng.
 
Neem die handmatige actie eens op. Dan heb je de macro en hoef je die alleen zodanig te wijzigen dat kolommen en/of cellen variabel kunnen zijn. Eventueel kan je die dan ook hier plaatsen voor hulp daarbij.
 
gezien de niet gestandaardiseerde inputfiles zou je ook eens kunnen kijken naar power query. (of ophalen en transformeren zoals het vanaf excel 2016 heet)

Als je (nog) geen kennis hebt van VBA kan dit een wat prettiger tool zijn omdat je daarin makkelijk ziet welke handelingen je toevoegt en heel makkelijk handelingen er weer uit haalt.
maar ook gewoon omdat deze tool is gebouwd om heel verschillende data bronnen om te vormen tot een bruikbaar geheel binnen Excel.
 
Ik heb de werkwijze beschreven en daarbij waar nodig een macro opgenomen.

Stap 1:

Happy flow:
- Aangereikte files openen binnen map ‘Retour gestuurde bestanden’
- Niet relevante tabbladen verwijderen. Enkel diegene die voorzien zijn van gegevens in kolom op ‘Adres’ + ‘Kostenplaats’ + ‘Opmerkingen’
- Opmaak wissen
- Hyperlinks wissen
- Formules verwijderen door kopiëren/plakken als waarde
- Filter instellen op ‘Adres’ + ‘Kostenplaats’ + ‘Opmerkingen’ op lege cellen
- Inhoud verwijderen binnen ingestelde filter
- Filters instellen op ‘Alles selecteren’
- Verwijderen van filter weergave
- Bestand opslaan

Uitzonderingen:
- Sommigen files zijn standaard in een filter weergave geopend. Deze dient eerst verwijderd te worden.
- Bij het openen van de files wordt er gevraagd om de gegevens bij te werken aangezien er een externe koppeling aanwezig is.
- Adres + Kostenplaats + Opmerkingen zijn geplaatst in kolom AH,AI,AJ. Soms komt het voor dat deze in een andere kolom zijn geplaatst.

Macro:

Sub Macro15()
'
' Macro15 Macro
'

'
Sheets(Array("a", "b", "c", "d", "e", _
"f")).Select
Sheets("Preferent").Activate
ActiveWindow.SelectedSheets.Delete
Cells.Select
Selection.ClearFormats
Selection.ClearHyperlinks
Selection.ClearFormats
Rows("3:3").Select
Selection.AutoFilter
ActiveSheet.Range("$A$3:$AJ$6000").AutoFilter Field:=34, Criteria1:="="
ActiveSheet.Range("$A$3:$AJ$6000").AutoFilter Field:=35
ActiveSheet.Range("$A$3:$AJ$6000").AutoFilter Field:=36, Criteria1:="="
Rows("22:22").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
ActiveWindow.SmallScroll Down:=-42
Cells.Select
Range("A22").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
End Sub

Stap 2:

Happy flow:
- Start de Macro samenvoegen bestanden om alle losse bestanden samen te voegen.

Macro:


Sub VoegExcelBestandenSamenIn1NieuwBlad()
' [TOPIC=848630///][NOHTML][rml][ Excel] Meerdere bestanden samenvoegen[/rml][/NOHTML][/TOPIC]
' deel 2

Dim wbSingleWorkbook As Excel.Workbook, wbFinalWorkbook As Excel.Workbook
Dim wsSingleSheet As Excel.Worksheet, wsFinalSheet As Excel.Worksheet
Dim strPath As String, strWorkbook(500) As String ' max 500 bestanden
Dim intCounter As Integer, n As Integer
Dim Answer As VbMsgBoxResult

strPath = "h:\test" ' Map met .xlsx-bestanden
intCounter = 1 ' teller
strWorkbook(intCounter) = Dir(strPath & "*.xlsx")

Do While strWorkbook(intCounter) <> ""

intCounter = intCounter + 1
strWorkbook(intCounter) = Dir

Loop

intCounter = intCounter - 1 ' want de laatste is leeg
Set wbFinalWorkbook = Workbooks.Add
Application.DisplayAlerts = False

Do While wbFinalWorkbook.Sheets.Count > 1

wbFinalWorkbook.Sheets(1).Delete

Loop ' We hebben maar 1 blad nodig

Application.DisplayAlerts = True
Set wsFinalSheet = wbFinalWorkbook.Sheets(1)

On Error GoTo Einde ' Error trapping AAN

For n = 1 To intCounter

Set wbSingleWorkbook = Workbooks.Open(Filename:=strPath _
& strWorkbook(n), ReadOnly:=True)

For Each wsSingleSheet In wbSingleWorkbook.Sheets

wsSingleSheet.UsedRange.Copy _
Destination:=wsFinalSheet.Cells _
(wsFinalSheet.Cells.SpecialCells _
(xlCellTypeLastCell).Row + 1, 1)

Next wsSingleSheet

wbSingleWorkbook.Close

Next n

On Error GoTo 0 ' Error trapping UIT

Einde:

Select Case Err.Number ' Foutmelding 1004 is
' hoogstwaarschijnlijk veroorzaakt
Case 1004 ' door iets te plakken dat boven
' de 65536 rijen uit zou komen
Answer = MsgBox(Err.Description & Chr(13) & Chr(13) & _
"Waarschijnlijk wordt dit bestand te groot..." & _
Chr(13) & "Verder gaan op nieuw blad?", _
vbCritical Or vbYesNo, "Error " & Err.Number & _
": " & Err.Description)

If Answer = vbYes Then

Set wsFinalSheet = wbFinalWorkbook.Sheets.Add
Resume

End If

Case 0 ' Niks aan 't handje :-)

Case Else ' Overige foutmeldingen

MsgBox Err.Description, _
vbCritical Or vbOKOnly, "Error " & Err.Number & _
" in bestand " & n

End Select

Set wbSingleWorkbook = Nothing
Set wbFinalWorkbook = Nothing
Set wsSingleSheet = Nothing
Set wsFinalSheet = Nothing

End Sub


- Zorg dat na het samenvoegen data onder kolom ‘Adres’ + ‘Kostenplaats’ + ‘Opmerkingen’ vallen onder AH,AI,AJ. Enkele bestanden verwijzen naar andere kolommen. Verplaats deze!
- Opmaak wissen
- Hyperlinks wissen
- Formules verwijderen door kopiëren/plakken als waarde
- Filter instellen op ‘Adres’ + ‘Kostenplaats’ + ‘Opmerkingen’ op lege cellen
- Verwijder alle irrelevante data.




Macro:

Sub Macro16()
'
' Macro16 Macro
'

'
Cells.Select
Range("R1").Activate
Selection.AutoFilter
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 20
ActiveSheet.Range("$A$1:$AN$22884").AutoFilter Field:=34, Criteria1:="="
ActiveSheet.Range("$A$1:$AN$22884").AutoFilter Field:=35, Criteria1:="="
Range("AJ1").Select
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 23
ActiveSheet.Range("$A$1:$AN$22884").AutoFilter Field:=36, Criteria1:="="
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1433").Select
Range(Selection, Selection.End(xlDown)).Select
Rows("1433:1433").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
ActiveWindow.SmallScroll Down:=-24
Selection.AutoFilter
End Sub


- Filter instellen op ‘Adres AH’
- Vervang alle ja, J in standaard Ja

Macro:

Sub Macro16()
'
' Macro16 Macro
'

'
Cells.Select
Range("R1").Activate
Selection.AutoFilter
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 20
ActiveSheet.Range("$A$1:$AN$22884").AutoFilter Field:=34, Criteria1:="="
ActiveSheet.Range("$A$1:$AN$22884").AutoFilter Field:=35, Criteria1:="="
Range("AJ1").Select
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 23
ActiveSheet.Range("$A$1:$AN$22884").AutoFilter Field:=36, Criteria1:="="
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1433").Select
Range(Selection, Selection.End(xlDown)).Select
Rows("1433:1433").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
ActiveWindow.SmallScroll Down:=-24
Selection.AutoFilter
End Sub
Sub Macro17()
'
' Macro17 Macro
'

'
Columns("AH:AH").Select
Selection.Replace What:="ja", Replacement:="Ja", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="J", Replacement:="Ja", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub


- Vervang alle nee, n , N in standaard Nee

Macro:

Sub Macro18()
'
' Macro18 Macro
'

'
Columns("AH:AH").Select
Selection.Replace What:="nee", Replacement:="Nee", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="n", Replacement:="Nee", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="N", Replacement:="Nee", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="Neeee", Replacement:="Nee", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="Neeee", Replacement:="Nee", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("AJ18").Select
End Sub


- Pas deze wijze ook toe op de kolommen ‘Kostenplaats AI’ en ‘Opmerkingen AJ’


Alvast bedankt voor jullie expertise. Ik heb helaas niet de mogelijkheid om Power query te installeren aangezien ik werk binnen een beveiligde Citrix omgeving.
 
Dappre,

wat @edmoor bedoelde toen hij schreef:

Neem die handmatige actie eens op. Dan heb je de macro en hoef je die alleen zodanig te wijzigen dat kolommen en/of cellen variabel kunnen zijn. Eventueel kan je die dan ook hier plaatsen voor hulp daarbij.
Klik om te vergroten...

plaats de excelfile waarin de opgenomen macro ook staat, liefst samen met een paar in te lezen bestandjes.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan