cut/paste probleem

[Rap261]

Hallo,


Wie kan me helpen in de aanpassing van onderstaande code

Private Sub CommandButton2_Click()
    Dim zoekletter As String, EersteRij, TempRij, c As Range
    zoekletter = "N1" 'UCase("*" & TextBox2.Text & "*")

        If CheckBox1 = True Then
        
        With ActiveSheet.Range("B19:B5000")
            Set c = .Find(What:=zoekletter, After:=[B5000], LookIn:=xlValues, _
            lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
            EersteRij = c.Row
            Do
            Union(Cells(c.Row, 7), Cells(c.Row, 11), Cells(c.Row, 13), Cells(c.Row, 14)).Copy Sheets(3).[B65536].End(xlUp).Offset(1, 1)    
          
            Set c = .FindNext (Union (Cells(c.Row, 7), Cells(c.Row, 11), Cells(c.Row, 13), Cells(c.Row, 14 + 1, "B"))      
  
            Loop While Not c Is Nothing And c.Row <> EersteRij
            Unload UserForm5
            UserForm5.Show
            Else
            Unload UserForm4
            UserForm4.Show
            End If
        End With
    End If
End Sub

De code hangt onder een zoek functie en kopieerd bepaalde cellen naar aan ander blad. Tot zover werkt het perfect
Echter, wanneer meerdere hits mogelijk zijn, kopieerd ie toch alleen maar een rij met cellen.
Zelf zit ik in de "Set c = .FindNext" regel te wroeten maar misschien zit ik verkeerd.

Graag jullie hulp

 

[Roncancio]

De FindNext regel klopt inderdaad niet.
Aan het eind van de regel staat bijvoorbeeld:

Cells(c.Row, 14 + 1, "B")

Waar staat die 14 + 1 voor?

Volgens mij moet je de regel vervangen door ...

Set c = .FindNext(c)

Persoonlijk geef ik de voorkeur aan Autofilter om het bereik te filteren en de gevonden waardes te gebruiken.

Met vriendelijke groet,


Roncancio

 

[Rap261]

Ron,

Cells(c.row 14.. staat voor de cell die gekopieerd moet worden
+1, "B" heb ik uit een soort gelijke code die wel alles onder elkaar kopieerd alleen betreft dit hele regels ipv alleen bepaalde cellen.
Onderstaand treft je het gedeelte waar ik dit vandaan heb (dit werk prima indien je de hele rij wilt kopieren)

Do
c.Rows.EntireRow.Copy Sheets(2).[B65536].End(xlUp).Offset(1, -1) 
Set c = .FindNext(Cells(c.Row + 1, "B"))
Loop While Not c Is Nothing And c.Row <> EersteRij

Helaas maakt jou optie geen verschil. Nog steeds wordt maar een hit gekopieerd

 

[Roncancio]

Toch wel.
Er zat nog een fout in. Je gebruikte Offset waardoor de regel steeds werd overschreven.
Zo klopt het wel.

Private Sub CommandButton2_Click()
    Dim zoekletter As String, EersteRij, TempRij, c As Range
    zoekletter = "N1" 'UCase("*" & TextBox2.Text & "*")

        If CheckBox1 = True Then
        
        With ActiveSheet.Range("B19:B5000")
            Set c = .Find(What:=zoekletter, After:=[B5000], LookIn:=xlValues, _
            lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not c Is Nothing Then
                EersteRij = c.Row
                Do
                    Union(Cells(c.Row, 7), Cells(c.Row, 11), Cells(c.Row, 13), Cells(c.Row, 14)).Copy Sheets(3).[C65536].End(xlUp).Offset(1, 0)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Row <> EersteRij
                Unload UserForm5
                UserForm5.Show
            Else
                Unload UserForm4
                UserForm4.Show
            End If
        End With
    End If

End Sub

Met vriendelijke groet,


Roncancio

 

[Rap261]

Ron,

goed nieuws en slecht nieuws

Jou aanpassing werk iid alleen waar het vanmiddag nog tot een minuut duurde, doet ie er nu ruim 10 min over om alles te vinden en te kopieren.
Bestand is 2700 rijen groot en hetgeen gekopieerd moet worden zit op ruim 900
Enig idee waar dit aan kan liggen?

 

[Roncancio]

Private Sub CommandButton2_Click()
If CheckBox1 = True Then
        With Range("B19:B5000")
            .AutoFilter 1, "N1"
            r = .SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Count
        End With
        Range("G19:G5000").SpecialCells(xlCellTypeVisible).Copy Worksheets(3).Range("C2")
        Range("K19:K5000").SpecialCells(xlCellTypeVisible).Copy Worksheets(3).Range("D2")
        Range("M19:M5000").SpecialCells(xlCellTypeVisible).Copy Worksheets(3).Range("E2")
        Range("N19:N5000").SpecialCells(xlCellTypeVisible).Copy Worksheets(3).Range("F2")
        
End If
End Sub

Indien het om zo veel records gaat, werk ik veel liever met Autofilter. Je filtert het bereik op de bepaalde waarde en vervolgens kopieer je in 1 keer de waardes naar het 3e werkblad.
Bovenstaande code was in ongeveer 1 seconde klaar met een werkblad met ruim 16.000 rijen die allen voorzien waren van veel formules.

Met vriendelijke groet,


Roncancio

 

[Rap261]

Ik snap je punt.
De userforms gebruik ik omdat ik daarmee de zoek opdrachten kan aangeven. Reden dat ik ze unload van te voren is zodat ze altijd gecentreerd in het scherm staan.

Bij een Autofilter denk ik aan al die pijltjes waarmee je kunt filteren. Bedoel je dit of in de zin van een marco?
De bedoeling is natuurlijk dat men kan aanvinken en op start kan drukken zodat de bestanden vanzelf samengesteld worden..

 

[snb]

of

Private Sub CommandButton2_Click()
  If CheckBox1 Then
    With Range("B19:N5000")
      .AutoFilter 1, "N1"
      .columns(6).resize(,8).Copy sheets(3).Range("C2")
      .autofilter
    end with

    sheets(3).range("D1:F1,H1").entirecolumn.delete        
  End If
End Sub

 

[Rap261]

Hi Ron


Dit is veel beter en werkt binnen 5 sec!
Wel kopieert ie standaard de eerste regel van het bereik (B19) en dan de filter. Ik weet niet waarom maar kan het verhelpen door standaard regel 2 te laten verwijderen

Sheets(3).Rows("2:2").Delete Shift:=xlUp

Bedankt, topic kan gesloten worden

 

[Rap261]

Hi Ron,

Ik hoop dat je nog even kunt helpen

Als resultaat wil ik alleen kolom A, B, E, en H hebben.
Ik probeer dit te bereiken door in de "copy" regel al een selectie op te geven maar dit werkt niet.
Zie pogingen

      '.Columns(1, 2, 5, 8).Copy Sheets(3).Range("B2")
      '.Columns.Range("A18:B2000, E18:E2000, H18:H2000").Copy Sheets(3).Range("B2")
      '.Columns([1], [F]).Copy Sheets(3).Range("B2")
      '.Columns(1).Resize(7, 11).Copy Sheets(3).Range("B2")

Ook als ik wel de hele rij laat kopieren en dan later de aanpassing wil maken lukt dit niet

Sheets(3).Range("C2:D2, F2:G2,").EntireColumn.Delete Shift:=xlToLeft
Sheets(3).Range("C2:D2, F2:G2,").Select.Delete Shift:=xlToLeft

Kun je mij vertellen wat ik fout doe?

 

[snb]

Ja, je richt je tot de verkeerde persoon

1e regel kopiëren onderdrukken:

Private Sub CommandButton2_Click()
  If CheckBox1 Then
    With Range("B19:N5000")
      .AutoFilter 1, "N1"
      .offset(1).columns(6).resize(,8).Copy sheets(3).Range("C2")
      .autofilter
    end with

    sheets(3).range("D1:F1,H1").entirecolumn.delete        
  End If
End Sub

Probeer niet afzonderlijke areas te kopiëren. Hou het gewoon simpel door de niet gewenste kolommen in 1 keer te verwijderen.
Dat gaat ook het snelst.

 

[Rap261]

Had ik nog niet eens in de gaten SNB, sorry

Volgens mij geef je me nu een alternatief voor het niet kopieren van standaard de "eerste" regel.
Dit had ik zelf opgelost door "Sheets(3).Rows("2:2").Delete Shift:=xlUp" maar toegegeven, jou optie is korter.

Neemt niet weg dat je m'n vraag misschien verkeerd hebt begrepen.
Mijn bestand is 100 kolommen groot en indien bijv "N1" in kolom B wordt gevonden, dient alleen kolom A, B, E en H gekopieerd te worden naar sheet 3.
Dit probeer ik te doen met de eerder genoemde pogingen maar loop steeds vast

Enig idee?

 

[snb]

Mijn bestand is 100 kolommen groot en indien bijv "N1" in kolom B wordt gevonden, dient alleen kolom A, B, E en H gekopieerd te worden naar sheet 3.

Private Sub CommandButton2_Click()
  If CheckBox1 Then
    With Range("A19:H5000")
      .AutoFilter 2, "N1"
      .offset(1).columns(1).resize(,2).Copy sheets(3).Range("A2")
      .offset(1).columns(5).Copy sheets(3).Range("C2")
      .offset(1).columns(8).Copy sheets(3).Range("D2")
      .autofilter
    end with
  End If
End Sub

Maar als werkblad 3 leeg is bij aanvang zou ik de hele range kopiëren en daarna in werkblad 3 de niet gewenste kolommen verwijderen met 1 VBA-regel (zie vorige posts)

 

[Rap261]

Ik geef ook de voorkeur aan kolommen verwijderen alleen ook dit lukt me niet.
Het lijkt als of elk bereik wat ik ingeef (range("X:X"), Columns(x,x,x)) niet goed is. (x= voorbeeld)
Extra info: werkblad 3 is niet helemaal leeg. De eerste regel van werkblad 3 is gevuld met de onderwerpen waarvan de resultaten er juist onder moeten komen

Heb net getest met elke kolom apart kopieren maar hij schiet gelijk omhoog qua tijd dat ie erover doet.

 

[snb]

Bekijk de code die ik plaats dan eens goed. bijv. http://www.helpmij.nl/forum/showthr...ste-probleem?p=4492873&viewfull=1#post4492873
En pas het eerst toe op een klein deel van je gegevens: maak een proefbestandje.

Private Sub CommandButton2_Click()
  If CheckBox1 Then
    With Range("A19:H5000")
      .AutoFilter 2, "N1"
      .Copy sheets(3).Range("A1")
      .autofilter
    end with
    sheets(3).range("C1:D1,F1:G1").entirecolumn.delete
  End If
End Sub

Hierna alleen nog de namen in rij 1 van werkblad 3 zetten (of juist niet omdat ze gewoon hetzelfde zijn als in rij 19 van het oorspronkelijke werkblad; en dus offset(1) niet nodig is).

 

[Rap261]

Goedemorgen SNB

Ik denk dat gisteren de dingen niet meer helder waren, vanmorgen opnieuw geprobeerd met het deleten van kolommen aan het eind van de marco en nu werkt het.

Thanks voor je uitleg en hulp!
Topic kan gesloten worden