Selectie van data (cel & row) in Macro aanpassen

Status
Niet open voor verdere reacties.
S

smvrolijk

Gebruiker
Lid geworden
15 mrt 2010
Berichten
26
Hoi,

In mijn enthusiasme heb ik een macro gemaakt die data van sheet All (naam van de sheet) via een macro verdeeld over een aantal andere sheets binnen dezelfde excel file.

In macro heb ik het zo opgezet dat in de sheet All via een filter iedere keer de geslecteerde data verplaatst wordt naar de desbetreffende sheet.

Dit loopt allemaal goed, misschien omslachtig opgezet (zie code hieronder), maar het werkt.

De data (aantal cellen en rows) in sheet All neemt iedere week toe, wordt dus groter.
Echter als ik de macro laat lopen copieert hij nog steeds alleen die cellen/rows die ik in eerste instantie had geselecteerd bij het aanmaken van de macro.
En neemt hij niet de nieuwe data mee.

Hoe moet ik dit aanpassen in de macro?

Ik ben nml geen code-expert, kan het slecht lezen. Een macro maken is voor mij het opnemen van een aantal handelingen.

Hieronder de code zoals hij nu is. Ik heb de code iets ingekort gezien het aantal sheets rond de 40 ligt en hier ik er nu maar 5 weergeef.........
Bijgevoegd tevens de file waarmee ik werk. Ook hier alleen de 5 sheets weergegeven die nu in de code staan, de andere heb ik gedelete. File werd anders te groot om hier te kunnen plaatsen.

Dank je wel voor het advies.

En als je advies geeft kan je het dan zo weergeven in de code van mij dat ik hem 1 op 1 kan copieren in mijn gemaakte macro?
Anders ben ik bang dat de oplossing voor mijn neus ligt maar ik het niet correct weet in te voegen

Dank je wel.


Code: 
Sub Macro4_Weekly_Report_Processing_Department_RAW_DATA_4_Verdeling()
'
' Macro4_Weekly_Report_Processing_Department_RAW_DATA_4_Verdeling Macro
'

'
Range("A1").Select
    ActiveSheet.Range("$A$1:$N$50000").AutoFilter Field:=7, Criteria1:="N800001"
    Range("H1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("N800001").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    ActiveWindow.Zoom = 90
    Sheets("all").Select
    ActiveSheet.Range("$A$1:$N$50000").AutoFilter Field:=7, Criteria1:="N800002"
    ActiveWindow.ScrollRow = 196
    ActiveWindow.ScrollRow = 293
    ActiveWindow.ScrollRow = 391
    ActiveWindow.ScrollRow = 488
    ActiveWindow.ScrollRow = 586
    ActiveWindow.ScrollRow = 683
    ActiveWindow.ScrollRow = 878
    ActiveWindow.ScrollRow = 975
    ActiveWindow.ScrollRow = 1073
    ActiveWindow.ScrollRow = 1170
    ActiveWindow.ScrollRow = 1365
    ActiveWindow.ScrollRow = 1170
    Selection.Copy
    Sheets("N800002").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveWindow.Zoom = 90
    Sheets("all").Select
    ActiveSheet.Range("$A$1:$N$50000").AutoFilter Field:=7, Criteria1:="N800010"
    Selection.Copy
    Sheets("N800010").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveWindow.Zoom = 90
    Sheets("all").Select
    ActiveSheet.Range("$A$1:$N$50000").AutoFilter Field:=7, Criteria1:="N700001"
    Selection.Copy
    Sheets("N700001").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveWindow.Zoom = 90
    Sheets("all").Select
    ActiveSheet.Range("$A$1:$N$50000").AutoFilter Field:=7, Criteria1:="N200001"
    Selection.Copy
    Sheets("N200001").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    ActiveWindow.Zoom = 90
End Sub
 

Bijlagen

Laatst bewerkt door een moderator:
Beste smvrolijk,

Dit komt omdat je na het toepassen van het filter niet de gefilterde cellen selecteert.
Je kunt dit bereiken door na iedere toepassing van het filter en voor Selection.Copy
de volgende code tussen te voegen

Code: 
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

Ik ben het met je eens dat het er wat omslachtig uitziet, maar omdat je er tevreden mee bent, heb ik er verder niet aangesleuteld.
Overigens zou ik de volgende regels ertussen uithalen, want die voegen niets toe.

Code: 
ActiveWindow.ScrollRow = 196
ActiveWindow.ScrollRow = 293
ActiveWindow.ScrollRow = 391
ActiveWindow.ScrollRow = 488
ActiveWindow.ScrollRow = 586
ActiveWindow.ScrollRow = 683
ActiveWindow.ScrollRow = 878
ActiveWindow.ScrollRow = 975
ActiveWindow.ScrollRow = 1073
ActiveWindow.ScrollRow = 1170
ActiveWindow.ScrollRow = 1365
ActiveWindow.ScrollRow = 1170
 
Hoi Jofred,

Ik heb beide aanpassingen gedaan en idd het werkt zoals ik het voor ogen hebt.
Mijn dank hiervoor.

Echter ben ik natuurlijk altijd bereid om zaken te leren en te verbeteren.

Als ik het niet zo omslachtig had moeten doen, hoe had de code er dan volgens jou uit moeten zien?

Maakt een andere (betere) code nog iets uit betreffende snelheid van uitvoering macro en/of size van de excel file?

Bvd.

Mvg
Sander
 
Sander,

Ik heb nog even gekeken, maar ik geloof dat ik het zo zou oplossen. Volgens mij zou dit iets sneller werken, dan jouw code.
Daarnaast is dan ook meer toepasbaar op andere bestanden.
Waar je even op moet letten is de naam van de basissheet (met alle waarden) en het nummer van de kolom waar de werkbladnamen in staan

Als extra heb ik toegevoegd een functie, die voorkomt dat er niet toegestane tekens worden gebruikt bij de naamgeving van een nieuw werkblad.

Ik hoop dat je er wat mee kan.

Code: 
Option Explicit

Sub opsplitsen()
Dim blnBladBestaat As Boolean
Dim intAantalKolommen As Integer
Dim intKolomWerkblad As Integer
Dim intTeller As Integer
Dim intRij As Integer
Dim lngTeller As Long
Dim strBlad As String
Dim sh As Worksheet
Dim shBasis As Worksheet

'naam van het werkblad waarin de op te splitsen waarden staan
strBlad = "all"
'kolomnummer waarin de waarde staat, waarvan een werkblad moet worden gemaakt
intKolomWerkblad = 7
Set shBasis = Sheets(strBlad)

Application.DisplayAlerts = False
'behalve de lijst met basisdata, gooien we alle werkbladen weg
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> shBasis.Name Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = False
'aantal kolommen bepalen in de basissheet
intAantalKolommen = shBasis.UsedRange.Columns.Count

For lngTeller = 2 To shBasis.UsedRange.Rows.Count
    strBlad = GeenLeestekens(shBasis.Cells(lngTeller, intKolomWerkblad))
    'testen of het werkblad al bestaat
    blnBladBestaat = False
    On Error Resume Next
    blnBladBestaat = Len(Sheets(strBlad).Name) > 0
    On Error GoTo 0
    
    If blnBladBestaat = False Then
        'het werkblad bestaat nog niet en gaan we dan aanmaken
        'en voorzien van een kopregel en de eerste regel data
        Sheets.Add.Move after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = strBlad
        For intTeller = 1 To intAantalKolommen
            Sheets(strBlad).Cells(1, intTeller).Value = shBasis.Cells(1, intTeller).Value
            Sheets(strBlad).Cells(2, intTeller).Value = shBasis.Cells(lngTeller, intTeller).Value
        Next intTeller
    Else
        'het blad bestaat al wel, dus voegen we de rij toe onder de laatste rij
        intRij = Sheets(strBlad).UsedRange.Rows.Count + 1
        For intTeller = 1 To intAantalKolommen
            Sheets(strBlad).Cells(intRij, intTeller).Value = shBasis.Cells(lngTeller, intTeller).Value
        Next intTeller
    End If
Next lngTeller
shBasis.Activate
Set shBasis = Nothing
End Sub

Function GeenLeestekens(ByVal Tekst As String) As String

'haalt "niet-toegestane" karakters uit de input-variabele Tekst
'zodat een tekenreeks overblijft, die kan worden gebruikt als werkbladnaam

Dim strTemp As String
Dim arrProhib As Variant
Dim lngTeller As Long
strTemp = Tekst

'alle "niet-toegestane" karakters
arrProhib = Array("/", "-", "[", "{", "#")

'verwijder alle ongewenste karakters
For lngTeller = LBound(arrProhib) To UBound(arrProhib)
    strTemp = Replace(strTemp, arrProhib(lngTeller), vbNullString)
Next lngTeller

GeenLeestekens = strTemp
End Function
 
Sander,

Nog een kleine aanvulling.
In bijgevoegd bestand is een formuliertje opgenomen, dat automatisch wordt getoond bij het openen van het bestand en waarmee je het bestand, het werkblad en het gegevens, waarop je de verdeling over de werkbladen wilt regelen kunt selecteren.
Nu is het nog breder toepasbaar, zonder dat je in de code moet gaan lopen sleutelen.

Succes ermee
 

Bijlagen

Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan