Excel Macro: Informatie splitsen over meerdere werkbladen.

[aurelius142]

Op het moment ben ik bezig met het schrijven van een macro om bepaalde cellen uit een rij te kopiëren naar een nieuw werkblad, afhankelijk van de waarde in een bepaalde cel.
Nu ben ik geen expert op het gebied van Macro's en heb ik daarom de basis van een andere code gebruikt.
Ik stuit echter tegen twee problemen met deze Macro.
1. Ik krijg de code enkel werkend als deze op "sheet1" staat. Als ik alles aanpas naar "sheet2" en "sheet3" werkt deze niet meer.
2. Ik krijg de code niet werkend om over meerdere sheets de data te spreiden, dus bijvoorbeeld als = A naar sheet3, als = B naar sheet4 etc.

Sub copycolumns()

Dim lastrow As Long, erow As Long

 

lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lastrow

If Sheet1.Cells(i, 3) = "A" Then

Sheet1.Cells(i, 2).Copy

erow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row

 

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 2)

 

Sheet1.Cells(i, 1).Copy

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 3)

 

Sheet1.Cells(i, 11).Copy

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 5)

 

Sheet1.Cells(i, 4).Copy

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 6)

 

Sheet1.Cells(i, 12).Copy

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 7)

 

Sheet1.Cells(i, 9).Copy

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 9)

 

Sheet1.Cells(i, 10).Copy

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 10)

End If

Next i

 

Application.CutCopyMode = False

Sheet2.Columns.AutoFit

Range("A1").Select

 

End Sub

Met hele rijen lukt het mij (deels) wel, hiervoor heb ik onderstaande code gevonden. Hier dienen echter de sheets dezelfde naam te hebben als de celwaarde.

Sub Filteren()

For Each c In Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    If c Like "*A*" Then
        c.EntireRow.Copy Sheets("A").Range("A" & Sheets("A").Range("A" & Rows.Count).End(xlUp).Row + 1)
    End If
    
    If c Like "*B*" Then
        c.EntireRow.Copy Sheets("B").Range("A" & Sheets("B").Range("A" & Rows.Count).End(xlUp).Row + 1)
    End If
    
    If c Like "*C*" Then
        c.EntireRow.Copy Sheets("C").Range("A" & Sheets("C").Range("A" & Rows.Count).End(xlUp).Row + 1)
    End If
    
    If c Like "*D*" Then
        c.EntireRow.Copy Sheets("D").Range("A" & Sheets("D").Range("A" & Rows.Count).End(xlUp).Row + 1)
    End If
    
Next
    
End Sub

Ik heb geprobeerd deze twee codes te combineren, echter lukte mij het niet.
Kan iemand mij adviseren hoe ik de eerste code werkend kan krijgen?

 

[VenA]

Ik denk dat het handig is als je even een voorbeeldje plaatst. De hoofdletter A heeft de ASCII waarde 65 dus als je vanaf A naar sheets(3) wil zal je wat van af moeten trekken.

 

[Timshel]

Probeer deze:

Sub CopyColumns()
    Dim ERow As Long
    Dim i As Long
    Dim Sh1, Sh2

    Set Sh1 = Sheet1
    For i = 2 To Sh1.Cells(Rows.Count, 1).End(xlUp).Row
        If Sh1.Cells(i, 3) <> "" Then
            Set Sh2 = Sheets("Sheet" & Asc(UCase(Sh1.Cells(i, 3))) - 63)
            ERow = Sh2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
            Sh2.Cells(ERow, 2).Resize(, 9) = Array(Sh1.Cells(i, 2), Sh1.Cells(i, 1), Sh2.Cells(ERow, 4), Sh1.Cells(i, 11), _
                Sh1.Cells(i, 4), Sh1.Cells(i, 12), Sh2.Cells(ERow, 8), Sh1.Cells(i, 9), Sh1.Cells(i, 10))
            'Sh1.Cells(i, 2).Copy Sh2.Cells(ERow, 2)
            'Sh1.Cells(i, 1).Copy Sh2.Cells(ERow, 3)
            'Sh1.Cells(i, 11).Copy Sh2.Cells(ERow, 5)
            'Sh1.Cells(i, 4).Copy Sh2.Cells(ERow, 6)
            'Sh1.Cells(i, 12).Copy Sh2.Cells(ERow, 7)
            'Sh1.Cells(i, 9).Copy Sh2.Cells(ERow, 9)
            'Sh1.Cells(i, 10).Copy Sh2.Cells(ERow, 10)
        End If
    Next
    'Sh2.Columns.AutoFit
    Range("A1").Select
End Sub