VBA om gegevens te filteren en te kopieren naar nieuwe werkmappen
Maike
Ik heb wekelijks een werkmap in stukjes op te delen en in nieuwe werkmappen
op te slaan (deze worden vervolgens per e-mail verzonden naar voor elke
werkmap verschillende personen).
In kolom D staan 4-cijferige codes waarop de rijen gefilterd worden; dit
wordt tevens de naam van de nieuwe werkmap. Het aantal rijen per code kan
varieren. De (opgenomen) macro zou ik 120 maal kunnen kopiëren; de code
vervangen en alles achter elkaar laten afdraaien; dit lijkt mij echter geen
correct VBA-gebruik.
Ik stel mij voor dat de macro steeds even stopt voor elke filter- en
kopieeractie zodat ik een code kan intypen (niet elke week zijn het dezelfde
codes), of dat ik de lijst met codes van die week aan de macro kan toevoegen
en dat deze de lijst automatisch langs loopt.
Wie helpt mij op weg?
De code die ik heb opgenomen ziet er zo uit:
Range("D2").Select
ActiveCell.FormulaR1C1 = "1040"
Range("D6").Select
Range("C5:U300").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("D1:D2"), Unique:=False
Range("C5").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="J:\1040.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
ActiveSheet.ShowAllData
Alvast heel veel dank voor diegenen die zich hierover buigen.
Hartelijke groeten,
Maike Weenk
Harbinger
Bij mij werkt
Selection.PasteSpecial Paste:=xlColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
niet maar ik heb het er voor jou maar even ingelaten
onderstaand de macro
Mocht je nog vragen hebben mail me gerust
Groet,
JW
probeer dit eens:
Private Code As String
Private Drive As String
Dim Myobject, Mycollection
Public Sub test()
'de drive waarin je op wilt slaan instellen
Drive = "c:\temp\"
'alleen unieke codes selecteren (werkt alleen tot 500 records)
'let op deze macro gebruikt tijdelijk de kolom AA
Range("D5:D500").AdvancedFilter Action:=xlFilterCopy,
CriteriaRange:=Range( _
"D5:D500"), CopyToRange:=Range("AA1"), Unique:=True
'alle verschillende codes opslaan
Range("aa2").Select
Range(Selection, Selection.End(xlDown)).Select
Mycollection = Selection
Selection.Delete
'Voor elke code een aparte file opslaan
For Each Myobject In Mycollection
Code = Myobject
'criterium bepalen
Range("D2").Select
ActiveCell.FormulaR1C1 = Code
'de records die aan het criterium voldoen selecteren
Range("D6").Select
Range("C5:U300").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("D1:D2"), Unique:=False
Range("C5").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
'de selectie kopieren in een nieuw werkboek
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
'werkboek opslaan op de vooraf ingestelde drive\map
ActiveWorkbook.SaveAs Filename:=Drive & Code & ".xls",
FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
ActiveSheet.ShowAllData
Next
End Sub
Maike
Heel hartelijk dank. Werkt (m.u.v. kolombreedte) fantastisch!
Die kolombreedte zal ik nog even posten, hopelijk heeft iemand daarvoor een
oplossing.