Regels verplaatsen

[HWV]

Beste,

Ik heb op de volgende locatie "P:\automatisering\tellijsten maken\2014\Gereed export Dimasys" ongeveer 100 bestanden staan met de opzet zoals dit voorbeeld bestand:

Bekijk bijlage 1A.xlsx

Dit is een bestand met in kolom B diverse locaties waar ik bepaalde locaties wil uit filteren naar een andere bestand in dit geval 1A_hoog.xlsx

1A011B
1A011C
1A012A
1A012B
1A013A
1A013B
1A013C

- De bedoeling is als de tweede positie vanaf rechts een 3 is dat deze verplaats moet worden naar een bestand voor dit werkblad 1A_hoog.xlsx
- De lege cel moet dan verwijderd worden
- De nummering in kolom 1 moet dan weer door lopen

Ben al bezig geweest maar dit is copy naar een andere werkblad maar zonder dat hij kijkt naar de tweede positie van rechts in kolom B, maar zouden we dit kunnen gebruiken!

Sub Naar_anderBlad()

 Dim c As Range
   For Each c In [B1:B10000]
        If c = "3" Then
            c.Rows.EntireRow.Copy
            ['1A_hoog'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
End Sub

Groet HWV

 

[Cobbe]

Deze macro snijdt die regels weg met een 3 als voorlaatste teken:

Sub Naar_anderBlad()

 Dim c As Range
   For Each c In [B1:B10000]
        If Mid(c, Len(c) - 1, 1) = "3" Then
            c.Rows.EntireRow.Cut
            ['1A_hoog'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
End Sub

Om de nummering weer aan te passen in het bronblad moet ik weten hoe de nummering nu wordt toepgepast.

 

[HWV]

Nummer 1 t/m ....

Beste,

bedankt voor de reactie.

Sub Naar_anderBlad()

 Dim c As Range
   For Each c In [B1:B10000]
        [COLOR="#FF0000"]If Mid(c, Len(c) - 1, 1) = "3" Then[/COLOR]
            c.Rows.EntireRow.Cut
            ['1A_hoog'!A65536].End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next
End Sub

de code slaat vast op de rode regel:
Ongeldige procedure-aanroep of ongeldig argument

De nummering gaat nu van 1 t/m... kan tot wel 100 gaan opvolgend.

HWV

 

[Cobbe]

Welke nummering? Dat zijn toch geen getallen die daar staan, of?
Kan je geen bestandje posten?

 

[HWV]

Staat in topic 1

Beste,

Deze staat in topic 1.
maar hier nogmaals

Bekijk bijlage 1A.xlsx

Groet HWV

 

[Cobbe]

Voor de nummering kan je dit toepassen:
=ALS(B4="";"";RIJ()-3)
in A4 en naar beneden doortrekken.

Voor de verplaatsing deze, wel het doel nog aanpassen (nu wordt naar blad1 geschreven.

Sub Macro1()
On Error Resume Next
With Sheets("1A")
    For rij = 105 To 2 Step -1
     nummer = .Cells(rij, 2)
     If IsEmpty(Mid(nummer, Len(nummer) - 1, 1)) = False And Mid(nummer, Len(nummer) - 1, 1) = "3" Then
       .Range("A" & rij).Resize(, 12).Copy
       With Sheets("Blad1")
         .Range("A" & .Range("A" & .Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
       End With
       .Rows(rij).Delete Shift:=xlUp
     End If
   Next
End With
End Sub

 

[HWV]

Beste Cobbe,

Bedankt voor je input, ik heb het bestand verwerkt in mijn huidige bestand en doet wat het moet doen.
Ik ben weer een stap verder.

Nogmaals bedankt

HWV