ombyt linier fra top til bund. fortsat

Har ikke så meget forstand på Excel, men hvis du indspiller en makro og kopierer VBA ser det således ud:

Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Hvis postnumrene står en gang pr. medlem, kan du bare sortere på almindeklig vis. Hvis hvert postnummer kun står en gang, vil jeg mene, at det hurtigste nok er at udfylde dem alle steder og så sortere.

Postnumrene står kun en gang. Vil helst undgå at indsætte postnumrene, da jeg i givet fald efterfølgende skal fjerne dem igen. Håbede at jeg vha. noget kode kunne løse problemet.

Husk backup er en go ting :-)

Sub Vend()
Application.ScreenUpdating = False
Set sh1 = Sheets("Ark1")
sh1.Select
Sheets.Add
ActiveSheet.Name = "temp"
Set sh2 = Sheets("temp")
sh1.Select
om:
rk1 = sh1.Cells(5000, "A").End(xlUp).Row
rk2 = sh1.Cells(5000, "B").End(xlUp).Row

tmp1 = sh2.Cells(5000, "B").End(xlUp).Row + 1
sh1.Range("A" & rk1 & ":G" & rk2).Cut sh2.Cells(tmp1, 1)

If rk1 >= 2 Then GoTo om

tmp1 = sh2.Cells(5000, "B").End(xlUp).Row

sh2.Range("A2:G" & tmp1).Cut sh1.Range("A2")
Application.DisplayAlerts = False
Sheets("temp").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Backup er en fin ting - har haft stor glæde af den :O))

Koden bringer mig et godt stykke på vej, men der er små udfordringer. Den første er, at postnummeret placers forkert eks.

nu står det som:

4000  hans Poulsen osv.
      Peter Hansen
      Kirsten Jensen
4500  Jens Hansen
      Ketty Jensen
      osv.

efter koden står teksten:
      hans Poulsen osv.
      Peter Hansen0
4000  Kirsten Jensen
      Jens Hansen
4500  Ketty Jensen

Postnummeret skulle helst stå ved det første navn - her skal 4000 stå ved Hans og 4500 ved Ketty.

Den anden udfordring er, at der er en overskrift, som forklarer hvad der stå i kolonnerne. Den skulle helst blive stående. Overskriften står i række 4.

Kan du indbygge ovennævnte i koden?

Ved ikke hvorfor jeg ikke har fået mail om denne tråd
men prøv denne:

Sub Vend()
Application.ScreenUpdating = False
Set sh1 = Sheets("Ark1")
sh1.Select
Sheets.Add
ActiveSheet.Name = "temp"
Set sh2 = Sheets("temp")
sh1.Select
om:
rk1 = sh1.Cells(5000, "A").End(xlUp).Row
rk2 = sh1.Cells(5000, "B").End(xlUp).Row

If rk1 = 4 Then GoTo slut

tmp1 = sh2.Cells(5000, "B").End(xlUp).Row + 1
sh1.Range("A" & rk1 & ":G" & rk2).Cut sh2.Cells(tmp1, 1)

If rk1 >= 5 Then GoTo om
slut:
tmp1 = sh2.Cells(5000, "B").End(xlUp).Row

sh2.Range("A2:G" & tmp1).Cut sh1.Range("A5")
Application.DisplayAlerts = False
Sheets("temp").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Hejsa - dejligt med respons på denne tråd - havde næsten opgivet det :0)

Din kommentar er næsten perfekt. Der er kun en lille detalje som jeg vil sætte pris på kommer med. I mine data er der en blank linie mellem hvert postnummer. Dsv. en blank linie inden et nyt postnummer begynder.

Hvis jeg ændre din kode i følgende to linier:

rk2 = sh1.Cells(5000, "D").End(xlUp).Row -> rk2 = sh1.Cells(5000, "D").End(xlUp).Row + 1

og

fortsat
tmp1 = sh2.Cells(5000, "D").End(xlUp).Row + 1 -> tmp1 = sh2.Cells(5000, "D").End(xlUp).Row + 2

så får jeg en blank linie, men så mister jeg gitterlinierne. Problemet er, at jeg ikke bare efterfølgende kan føje gitterlinierne til, da datasættet kan have en variabel antal kolonner. Hvordan takler jeg dette sidste problem?

Jeg har ændret lidt i kolonner og rækker i min kode grundet opbygning af mine data. Her er hele koden som den ser ud nu.

Sub Vend()
Application.ScreenUpdating = False
Set sh1 = Sheets("ark1")
sh1.Select
Sheets.Add
ActiveSheet.Name = "temp"
Set sh2 = Sheets("temp")
sh1.Select
om:
rk1 = sh1.Cells(5000, "B").End(xlUp).Row
rk2 = sh1.Cells(5000, "D").End(xlUp).Row + 1

If rk1 = 4 Then GoTo slut

tmp1 = sh2.Cells(5000, "D").End(xlUp).Row + 2
sh1.Range("A" & rk1 & ":J" & rk2).Cut sh2.Cells(tmp1, 1) ' linien der kopiere

If rk1 >= 5 Then GoTo om
slut:
tmp1 = sh2.Cells(5000, "D").End(xlUp).Row

sh2.Range("B2:J" & tmp1).Cut sh1.Range("B5")
Application.DisplayAlerts = False
Sheets("temp").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Det er et smart trick du bruger til kopiering af et helt postnummer :=))

Gitterlinier kan insættes via vba
er det kun en type rammer du anvender eller.. ?

jeg anvender en tynd streg til gitteret og en tyk streg til at indramme hele datasættet.

Start makrooptager og lav de tynde rammer, stop optager
Start makrooptager og lav den tykke ramme, stop optager

indsæt begge koder her, så skal jeg forsøge at lave den dynamisk

Sub tyndestreger()
    Range("B4:J20").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub

Sub tykkestreger()
    Range("B4:J20").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("I23").Select
End Sub

Jeg går ud fra at B4 altid er øverste venstre hjørne
men at nederste højre kan ændres
men er det kun antal rækker eller er det også antal kolonner der ændres?

B4 er konstant, mens antallet af rækker og kolonner er variable

Indsæt denne stump i starten af begge koder

kolonne = Cells(4, 255).End(xlToLeft).Column
' - ret evt. 4 til den række med flest kolonner
række = Cells(65000, "B").End(xlUp).Row
' - ret evt "B" til den kolonne med flest rækker
Range(Cells(4, 2), Cells(række, kolonne)).Select

og slet denne i begge koder
Range("B4:J20").Select

Tusind tak for hjælpen - virker helt perfekt. :0))
God weekend når du når så langt

velbekom, tak i lige måde :-)