Ik heb een nieuwe macro gemaakt en getest die de gegevens in het 3e werkblad zet volgens het voorbeeld van Blad1.
De macro heet Verplaatsen.
Met vriendelijke groet,
Roncancio
Ronancia,
Ik heb het geretourneerd bestand met de macro getest. Werkt in de basis PERFECT !! Grote klasse. Hartelijke dank.
Gelukkig was er een uitdaging om ermee verder te gaan en deze te kneden naar mijn wensen.
Toegevoegd zijn:
Zeker te zijn dat de macro runt van Blad 2
Sorteren van de inputinformatie
Verwijderen van de eerste (lege) rij van Blad 3 (na transponeren) en aanpassen van de kolombreedte.
Dat Blad3 geheel gewist wordt neem ik op in de gebruiksaanwijzing.
Misschien is hier een onderbreking van de macro en een messagebox een goed alternatief. Hoe te regelen /
code
----------------------------------
Sub Verplaatsen()
Application.ScreenUpdating = False 'Voorkomt flikkeren van het beeldscherm
ActiveWorkbook.Worksheets("Blad2").Select
'Gegevens sorteren
Columns("A:B").Select
ActiveWorkbook.Worksheets("Blad2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Blad2").Sort.SortFields.Add Key:=Range("A2:A65536") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Blad2").Sort.SortFields.Add Key:=Range("B2:B65536") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Blad2").Sort
.SetRange Range("A1:B65536")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("C1").Select
'Gegevens transponeren
Dim lRij As Long
Dim lKol As Long
Dim lSRij As Long
lRij = 1
Worksheets(3).Cells.ClearContents
While Worksheets(2).Cells(lRij, "A") <> ""
With Worksheets(3).Range("A:A")
Set NR = .Find(Worksheets(2).Cells(lRij, "A"), LookIn:=xlValues, LOOKAT:=xlWhole)
If Not NR Is Nothing Then
lKol = Worksheets(3).Cells(NR.Row, "IV").End(xlToLeft).Column + 1
Worksheets(3).Cells(NR.Row, lKol).Value = Worksheets(2).Cells(lRij, "B")
Else
lSRij = Worksheets(3).Range("A65536").End(xlUp).Row + 1
Worksheets(3).Cells(lSRij, "A").Value = Worksheets(2).Cells(lRij, "A")
Worksheets(3).Cells(lSRij, "B").Value = Worksheets(2).Cells(lRij, "B")
End If
End With
lRij = lRij + 1
Wend
' Eerste_regel_wissen en kolombreedte aanpassen
Sheets("Blad3").Select
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("C1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C1").Select
End Sub
---------------------------------------------------------
Nogmaals dank ! en groeten van Ton
