• 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.

Aantal rijen kiezen in macro

Status
Niet open voor verdere reacties.
U

URLeraar

Gebruiker
Lid geworden
19 jul 2001
Berichten
168
Ik heb de macro die ik gevonden heb op http://www.rondebruin.nl/copy2.htm

een beetje aangepast.

Nog 1 probleempje: is het mogelijk om ervoor te zorgen dat ik via een keuzeformulier zoals in ASAP bestaat




kan beslissen hoeveel rijen er moeten gekopieerd worden.

Nu heb ik standaard in de macro 10 rijen voorzien (zie vet) en moet ik de macro veranderen indien er meer of minder rijen nodig zijn.
Noodoplossing zou zijn verschillende macro's naargelang het aantal rijen; maar keuzebox zou leuker zijn.


Aangepaste macro van http://www.rondebruin.nl/copy2.htm


Sub Rijen_10_samenvoegen()

' Sneltoets: CTRL+shift+z


Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "BrstZkje" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("BrstZkje").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "BrstZkje"
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "BrstZkje"

'loop through all worksheets and copy the data to the DestSh
For Each sh In Worksheets(Array("Klas1", "Klas3"))
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)

'This example copies everything, if you only want to copy
'values/formats look at the example below this macro
sh.Range("A1:Z10").Copy DestSh.Cells(Last + 1, "A")
End If
Next

Application.Goto DestSh.Cells(1)

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub






_________________________________________________________________
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
 
Kan zoets helpen?

MyRows = InputBox("Hoeveel Rijen?")
Range("A1:Z" & MyRows).Select

MVG - Marrosi
 
In plaats van:

Range("A1:Z" & MyRows).Select

bedoel ik:

Range("A1:Z" & MyRows).Copy .....enz....
 
Hoi Marrosi,

Ik heb dus wat je voorstelt ingevoegd (hopelijk op de juiste plaats?)
Door de groene zin krijg ik inderdaad een invoerbox met de vraag hoeveel rijen; maar daarna een foutmelding (door de rode zin)

Misschien vul ik het vak ook verkeerd in: ik heb geprobeerd met A1:A5 en ook A1:5

Alvast bedankt voor het meedenken.


Sub Rijen_10_samenvoegen()

' Sneltoets: CTRL+z


Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "BrstZkje" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("BrstZkje").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "BrstZkje"
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "BrstZkje"

For Each sh In Worksheets(Array("5seta", "5kan", "5h-bi", "6BIh", "6STW1", "6STW1", "Hitek"))
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)

MyRows = InputBox("Hoeveel Rijen?")
Range("A1:Z" & MyRows).Copy DestSh.Cells(Last + 1, "A")
End If
Next

Application.Goto DestSh.Cells(1)

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
 
Laatst bewerkt:
Op de vraag: Hoeveel rijen? moet ik met getal antwoorden, hé.

Maar... na het invullen en op OK klikken, blijft de inputbox staan... :(
 
AANPASSING POST: voer onderstaande code niet uit; zit een fout in!

Code: 
Sub Rijen_10_samenvoegen()

' Sneltoets: CTRL+z

    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim MyRows

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "BrstZkje" if it exists
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("BrstZkje").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "BrstZkje"
    Set DestSh = ThisWorkbook.Worksheets.Add
    DestSh.Name = "BrstZkje"

    For Each sh In Worksheets(Array("5seta", "5kan", "5h-bi", "6BIh", "6STW1", "6STW1", "Hitek"))
        If sh.Name <> DestSh.Name Then
            Last = LastRow(DestSh)
            sh.Select
            Set MyRows = Application.InputBox("Selecteer de rijen?", "Rijen selecteren", Rows(1), Type:=8)
            If Not MyRows = False Then MyRows.EntireRow.Copy DestSh.Cells(Last + 1, 1)
        End If
    Next

    Application.Goto DestSh.Cells(1)

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Wigi
 
Laatst bewerkt:
Bedankt voor het helpen Wigi; maar de inputbox verschijnt wel; maar niet meteen duidelijk wat moet ingevuld worden en wanneer er toch iets aanvaard wordt dan blijft ie maar vragen "Selecteer de rijen?" en geraak je er niet meer uit.
Excel kan dus niet meer afgesloten worden.
 
Ik denk dat dit het wel gaat doen:

Code: 
Sub Rijen_10_samenvoegen()

' Sneltoets: CTRL+z

    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim MyRows

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "BrstZkje" if it exists
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("BrstZkje").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "BrstZkje"
    Set DestSh = ThisWorkbook.Worksheets.Add
    DestSh.Name = "BrstZkje"

    For Each sh In Worksheets(Array("5seta", "5kan", "5h-bi", "6BIh", "6STW1", "6STW1", "Hitek"))
        If sh.Name <> DestSh.Name Then
            Last = LastRow(DestSh)
            sh.Select
            Set MyRows = Application.InputBox("Selecteer de rijen?", "Rijen selecteren", Type:=8)
            If Not MyRows Is Nothing Then MyRows.EntireRow.Copy DestSh.Cells(Last + 1, 1)
        End If
    Next

    Application.Goto DestSh.Cells(1)

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Wigi
 
Excel loopt nu niet meer vast.
Maar... om het even wat ik invul, er komt geen einde aan de vraag "Selecteer de rijen?"

Misschien moet je wel opgeven wat er moet ingevuld worden: bijv. getal of letter+ getal en na 2 keer zou het vragen moeten ophouden:)
 
Ik kan op mijn PC de rijen selecteren en dan gaat de code verder.
 
En kun je concreet aangeven wat je invult om bijv. de 5 eerste rijen in te vullen?
Ik zeg maar iets hé: A1:A5 of 1:5 of ????

Ik ben +/- een leek hé :rolleyes:

Je zou moeten te zien krijgen (denk ik): Selecteer de rijen? - vul hier bijv. A1:A5 in
 
Zoals ik al schreef: als de box er staat, selecteer de rijen in het blad die je wil.

Hang anders eens jouw bestandje bij, evt. met fictieve gegevens.
 
Selecteren met de muis bedoel je?
Lukt helaas niet.

Of op een andere manier?
 
Als ik dit uitvoer in een nieuw blad, en met de muis een aantal rijen selecteer, dan werkt het normaal.

Code: 
Sub Rijen_10_samenvoegen()

' Sneltoets: CTRL+z

'    Dim sh As Worksheet
'    Dim DestSh As Worksheet
'    Dim Last As Long
    Dim MyRows
'
'    With Application
'        .ScreenUpdating = False
'        .EnableEvents = False
'    End With
'
'    'Delete the sheet "BrstZkje" if it exists
'    Application.DisplayAlerts = False
'    On Error Resume Next
'    ThisWorkbook.Worksheets("BrstZkje").Delete
'    On Error GoTo 0
'    Application.DisplayAlerts = True
'
'    'Add a worksheet with the name "BrstZkje"
'    Set DestSh = ThisWorkbook.Worksheets.Add
'    DestSh.Name = "BrstZkje"
'
'    For Each sh In Worksheets(Array("5seta", "5kan", "5h-bi", "6BIh", "6STW1", "6STW1", "Hitek"))
'        If sh.Name <> DestSh.Name Then
'            Last = LastRow(DestSh)
'            sh.Select
            Set MyRows = Application.InputBox("Selecteer de rijen?", "Rijen selecteren", Type:=8)
            If Not MyRows Is Nothing Then MsgBox MyRows.EntireRow.Address 'MyRows.EntireRow.Copy DestSh.Cells(Last + 1, 1)
'        End If
'    Next
'
'    Application.Goto DestSh.Cells(1)
'
'    With Application
'        .ScreenUpdating = True
'        .EnableEvents = True
'    End With
End Sub

Wigi
 
Hier mijn bestand, maar als ik de inputbox zie, dan kan ik enkel iets invullen en mijn muis kan geen enkele cel selecteren.
Benieuwd hoe je dat doet :o
 

Bijlagen

Hier heb ik wel op moeten zoeken zeg! Maar ik heb het wel gevonden ;)

Je mag nl. ScreenUpdating niet op False zetten. Als je dat wel doet, verbied je Excel om het scherm te "verversen". Maar als je dan rijen moet aanduiden op het scherm, zal Excel ook niet verversen. Je kan zelfs niets aanklikken!

Dat weten we dan ook alweer... :)

Wigi
 
Klopt: in het begin 2 keer True i.p.v. False = probleem opgelost.

Hartelijk dank Wigi :thumb:

En nu begrijp ik ook waarom je verschillende keren de inputbox en de vraag krijgt: Selecteer de rijen?

Bij elk blad uit de "array" moet je aangeven wat gekopieerd moet worden naar het "Master-blad".

Vraagje: zou dat ook in 1 keer kunnen? Ik bedoel dat de 7 werkbladen waaruit ik gegevens haal in 1 beweging geselecteerd/gegroepeerd worden en dat ik daaruit dan in 1 keer hetzelfde gebied (geldig voor de 7 bladen) selecteer.

Ik zou dan iets minder precies werken, maar wel sneller :)
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan