Macro voor transponeren

[Valijn]

Hoi,

Ik ben bezig een tabel aan te leggen van basisscholen.
Informatie, zoals (mail)-adres, website, etc haal ik van het web en plak ik in Excel (zie bijlage), waarna de volgende handelingen moeten worden verricht:
- gegevens selecteren
- opdracht 'kopiëren' geven
- naar de eerste cel op de volgende rij gaan
- opdracht plakken speciaal; transponeren geven
- de eerder geplakte gegevens opnieuw selecteren en verwijderen.

Ik kom er niet ui om dit in een macro te laten werken; hieronder de 'listing' zoals totnutoe gemaakt:

Sub Trans()
'
' Trans Macro
' De macro is opgenomen op 30-6-2006.
'
Range("B984:B994").Select
Selection.Copy
Range("A982").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A984:B995").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A985").Select
End Sub


Probleem is natuurlijk, dat de aangegeven selecties steeds met één rijnummer wordt verhoogd.
De macro moet dus alle handelingen verrichten vanaf het moment det de gegevens van het web zijn 'geplakt', waarbij de actieve cel die in de linker-bovenkant van de selectie is (in de bijlage A984).
Ik hoop dat iemand me kan helpen, want in moet ze handers 'handmatig' nog zo'n 3500 herhalen .........

Bij voorbaat dank, Valijn

 

[Valijn]

Hoi,

Tot nu toe helaas geen reactie ....
Dan toch maar RSI-verschijnselen?

Valijn

 

[Wigi]

Dit zou moeten werken:

Sub transpose()
    With Range("B1").End(xlDown)
        While WorksheetFunction.CountIf(Range("A:A"), "Postadres") > 0
            Range(.End(xlDown), .End(xlDown).End(xlDown)).Copy .Offset(1, -1)
            .End(xlDown).CurrentRegion.Clear
        Wend
    End With
End Sub

Indien niet, hang een voorbeeldbestandje bij

Groeten

Wigi

 

[Wigi]

Na tests van mij bleek er nog een foutje te zitten in het vorige. Dit werkt:

Sub transpose()
    While WorksheetFunction.CountIf(Range("A:A"), "Postadres") > 0
        Range(Range("B1").End(xlDown).End(xlDown), Range("B1").End(xlDown).End(xlDown).End(xlDown)).Copy
        Range("B1").End(xlDown).Offset(1, -1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, transpose:=True
        Range("B1").End(xlDown).End(xlDown).End(xlDown).CurrentRegion.Clear
    Wend
    Application.CutCopyMode = False
    Range("B1").End(xlDown).Offset(1, -1).Select
End Sub

Indien niet, hang zeker een voorbeeldbestandje bij.

 

[Valijn]

Hoi Wigi,

Nee helaas, je macro werkt niet. Sterker nog: als ik hem uitvoer worden alle gegevens die in de tabel stonden gewist ...... .

Ik heb in een voorbeeldmap zo nauwkeurig mogelijk aangegeven, welke 'handelingen' ik graag in een macro zou zien.

Groet, Teun

 

[Wigi]

Hier is ie

Sub transpose()
    While WorksheetFunction.CountIf(Range("A:A"), "Postadres") > 0
        Range(Range("A1").End(xlDown).Offset(0, 1).End(xlDown), Range("A1").End(xlDown).Offset(0, 1).End(xlDown).End(xlDown)).Copy
        Range("A1").End(xlDown).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, transpose:=True
        Range("A1").End(xlDown).End(xlDown).CurrentRegion.Clear
    Wend
    Application.CutCopyMode = False
    Range("A1").End(xlDown).Offset(1, 0).Select
End Sub

Het probleem zat hem in het feit dat kolom B lege cellen bevat. In de huidige versie ga ik ervan uit dat kolom A geen lege cellen heeft (dus de schoolnaam is steeds gekend).

Wigi

 

[Valijn]

Hoi Wigi,


Perfect! Het werkt.
Alleen de laatste 'stap' pakt'ie niet: dat de actieve cel drie cellen onder de laatst ingevulde rij moet worden voor de volgende knip en plakactie.
Ik moet aan het eind dus steeds 'tweemaal pijltjestoets naar beneden' doen.
Dat is niet onoverkomelijk, maar misschien is ook deze handeling nog te 'macromatiseren'?

Dank, V.

 

[Wigi]

Ik begrijp wat je wilt, maar volgens mij is dat niet nodig. De macro zoekt automatisch naar de cellen die hij moet transponeren, het kan dus perfect meer dan 3 cellen ertussen zijn. De startpositie is irrelevant voor de macro. Als je het toch per sé wilt, moeilijk is het niet.

 

[Wigi]

Vervang de laatste regel

Range("A1").End(xlDown).Offset(1, 0).Select

door

Range("A1").End(xlDown).Offset([B]3[/B], 0).Select

Wigi

 

[Valijn]

Hoi Wigi,

Het werkt perfect. Gaat me veel rsi-handeling besparen.

Hartstikke bedankt, Teun