foutmelding: next zonder for

[ericabt]

hallo,

Op basis van onderstaande tekst wil ik van rij 1 to 100 de cellen in kolom 2-9 selecteren van rijen die in de eerste kolom een 1 hebben staan.
Ik krijg alleen een foutmelding "next zonder for".

Waar gaat het fout?

Sub bereikselecteren()

    Dim i As Integer
    
    For i = 1 To 100
    If Cells(i, 1).Value = 1 Then
    Range(Cells(i, 2), Cells(i, 9)).Copy
    Next i
End Sub

 

[edmoor]

Je mist een End If.

Sub BereikSelecteren()
    Dim i As Integer
    
    For i = 1 To 100
        If Cells(i, 1).Value = 1 Then
            Range(Cells(i, 2), Cells(i, 9)).Copy
        End If
    Next i
End Sub

 

[ericabt]

ouch, dat is een pijnlijke misser.

Hij loopt nu, alleen hij loopt niet zoals ik wil. Ik wil namelijk de cellen selecteren in in alle rijen die voldoen aan het criterium (dat er in de eerste kolom een 1 staat). De loop pakt nu alleen de laatste. Logisch achteraf, maar hoe kan ik de loop de selecties verzamelen en er een totaalselectie van maken.

 

[edmoor]

Dat 'ie alleen de laatste pakt is uiteraard logisch als je je code bekijkt.
Afhankelijk van wat je ermee wilt doen kun je beter een array declareren en iedere cel daar in stoppen.
Wat probeer je precies te doen?

Zoiets dus:

Sub BereikSelecteren()
    Dim i As Integer
    Dim tabel() As String
    
    For i = 1 To 24
        If Cells(i, 1).Value = 1 Then
            ReDim Preserve tabel(i)
            tabel(i) = Cells(i, 1).Value
            Debug.Print tabel(i)
        End If
    Next i
End Sub

Maar dan aangepast voor je eigen situatie.

 

[ericabt]

Wat ik wil bereiken is dat er gezocht wordt in de rijen 1 tot 100 naar de waarde 1 in kolom A. Van alle gevonden rijen (met waarde 1) wil ik dat van de betreffende rij de waarde uit kolom 2 t/m 9 geselecteerd wordt. Dus de selectie moet als het ware groeien terwijl de macro door de loops loopt.

 

[edmoor]

En wat bedoel je met selecteren? Dat de betreffende cellen blauw worden om naderhand 1 opdracht op uit te voeren?

 

[ericabt]

ja dat is de bedoeling. Uiteindelijk moet de selectie gekopieerd worden naar een andere sheet.

 

[edmoor]

Ok, dan zou je er zoiets van kunnen maken:

Sub BereikSelecteren()
    Dim i As Integer
    Dim y As Integer
    Dim s As String
    
    For i = 1 To 100
        If Cells(i, 1).Value = 1 Then
            For y = 2 To 9
                s = s & Cells(i, y).Address & ":" & Cells(i, y).Address & ","
            Next y
        End If
    Next i
    s = Mid(s, 1, Len(s) - 1)
    Range(s).Select
End Sub

Maar je zou het ook direct naar het andere sheet kunnen schrijven in plaats van te selecteren, kopiëren en plakken.

 

[ericabt]

bedankt voor de reactie. Ik ben warm. Tot de laatste regel loopt het. In "s" zit de hele range als string gevangen, echter de laatste regel geeft een foutmelding.

Uiteindelijk zal ik inderdaad direct copy, pasten ipv select, copy, paste

 

[edmoor]

Je verteld er niet bij wat dan de foutmelding is. Bij mij werkt dat voorbeeld prima.

 

[Roncancio]

Met een autofilter hoef je niet regel voor regel te controleren.
Dat werkt sneller.

Sub Overzetten()
Range("A:I").AutoFilter 1, 1
Range("A1").CurrentRegion.SpecialCells(12).Copy WorkSheets(2).Range("A1")

End Sub

Met vriendelijke groet,


Roncancio

 

[edmoor]

En da's nog veel beter
Maar ik blijf wel benieuwd naar die foutmelding.

 

[ericabt]

@ roncancio:

Het werkt(e) wel maar het gaat ongelooflijk traag. Waardoor ontstaat die vertraging.

Ik heb even een testbestandje bijgevoegd.

Bekijk bijlage test.xlsm

 

[ericabt]

@ edmoor,

hierbij een voorbeeld waar jouw suggestie in is verwerkt.

laatste regel gaat niet goed.

Bekijk bijlage bereik selecteren_vb.xlsm

aanvulling: onderstaande doet het wel.


Dim i As Integer
Dim y As Integer
Dim s As String

For i = 1 To 100
If Cells(i, 1).Value = 1 Then

s = s & Cells(i, 2).Address & ":" & Cells(i, 9).Address & ","

End If
Next i
s = Mid(s, 1, Len(s) - 1)
Range(s).Copy

 

[Roncancio]

Sub Overzetten()
Range("A5:I5").AutoFilter 1, 1
Range("A5").CurrentRegion.SpecialCells(12).Copy Worksheets("blad3").Range("A1")

End Sub

Met vriendelijke groet,


Roncancio

 

[Roncancio]

De laatste regel in de andere code gaat niet goed omdat je niet hebt aangegeven waar je de gegevens naar toe wilt kopiëren.
De laatste zou dus bijvoorbeeld kunnen zijn:

Range(s).Copy Blad3.Range("A1")

Met vriendelijke groet,


Roncancio

 

[Warme bakkertje]

Sub tst()
    Dim tabel()
    With Sheets("Blad1")
        sq = .Range("A5:I" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    x = 1
    For i = 1 To UBound(sq)
        If sq(i, 1) = 1 Then
            ReDim Preserve tabel(1 To 8, 1 To x)
            For ii = 1 To 8
                tabel(ii, x) = sq(i, ii + 1)
            Next
            x = x + 1
        End If
    Next
    Sheets("Blad3").Range("A1").Resize(UBound(tabel, 2), 8) = WorksheetFunction.Transpose(tabel)
End Sub

 

[ericabt]

bedankt voor alle reacties. Het loopt nu, dus case closed.