Sorteren met VBA

[bascas]

Beste helpers,

In kolom A staan opmerkingen, in kolom B emailadressen, hoe kan ik kolom B sorteren liefst op Alfabet.

Groet Bas

 

[Jack Nouws]

Dit is op alfabet maar ik geloof niet dat dit juist voor je is

  With Blad1
    .Cells(1).CurrentRegion.Sort .Cells(1, 2), 1, , , , , , xlNo
  End With

​

 

[bascas]

Jack, ik heb de code een beetje aangepast en het werkt nu. Dus toch op de goede weg geholpen. Bedankt.

Sub Sorteren()
' sorteren van emailadressen

With Sheets("Samenvoegen")
    .Cells(1).CurrentRegion.Sort .Cells(1, 2), 1, , , , , , xlNo
  End With
  End Sub

Zou jij weten hoe je nu het onderste (2e) mailadres weg zou kunnen halen uit kolom B, maar de tekst in kolom A moet wel blijven staan. De daarop volgende vraag wordt of dan de 2 of 1 opmerkingen in kolom A met het mailadres in kolom B omkadert kunnen worden?

 

[Jack Nouws]

Probeer dit eens uit

Sub Dubbel()
  With Blad1
    lr = .Cells(Rows.Count, 2).End(xlUp).Row
      For i = lr To 2 Step -1
        If .Cells(i, 2) = .Cells(i - 1, 2) Then .Cells(i, 2).ClearContents
      Next
   End With
End Sub

Sub Borders()
  With Blad1
    .Range("A1").CurrentRegion.Borders.LineStyle = xlNone

    For Each c In .Range("B1", .Cells(Rows.Count, 2).End(xlUp))
      If c.Value <> "" Then
        With .Cells(c.Row, 1).Resize(, 2)
          .BorderAround , xlThin
          .Borders(xlInsideVertical).Weight = xlThin
        End With
      End If
    Next
    
  End With
End Sub

 

[bascas]

Jack, bedankt voor je hulp. De sub Dubbel werkt, maar bij de Sub Borders gebeurt nog niet helemaal wat ik voor ogen had. Ik heb de bedoeling in een voorbeeldbestand geprobeerd duidelijk te maken. Wellicht dat er ook eerst alle bestaande kaders weggehaald moeten worden, alvorens de nieuwe opmaak geplaatst kan worden.
Groet Bas

Bekijk bijlage omkaderen.xlsx

 

[Jack Nouws]

Kijk eens of het hier mee lukt

Sub Borders()
   With Blad2.Cells(1).CurrentRegion
      .Borders.LineStyle = xlNone
      .AutoFilter Field:=2, Criteria1:="<>"
      .Cells.SpecialCells(12).BorderAround , xlThin
      .Cells.SpecialCells(12).Borders(xlInsideHorizontal).Weight = xlThin
      .AutoFilter
    End With
End Sub

 

[bascas]

Helaas Jack, het werkt niet. Excel zet niet 2 regels in 1 omkadering.

 

[Jack Nouws]

Da's jammer, ik kan ook niet zien waar of wat er fout gaat.

 

[HSV]

Je was er bijna Jack.

Zo wordt blad1 als blad2 (Dit is de bedoeling)

Sub Borders()
   With Blad1.Cells(1).CurrentRegion
      .Borders.LineStyle = xlNone
      .BorderAround , xlThin
      .AutoFilter 2, "<>"
      .Cells.SpecialCells(12).Borders(xlEdgeTop).Weight = xlThin
      .Cells.SpecialCells(12).Borders(xlInsideHorizontal).Weight = xlThin
      .AutoFilter
    End With
End Sub

 

[bascas]

Super bedankt Harry, het werkt en precies wat ik zocht.
Ik heb met jullie hulp en een beetje zoeken en pielen de volgende code, maar zou het fijn vinden als een van jullie hier nog een keer naar wil kijken of het korter kan en er geen onnodige dingen in staan.

Sub Methode5()
'Verwijder de regels in tabblad kto en nps die niet gevuld zijn met een emailadres

ActiveWorkbook.Sheets("NPS").Range("G:G"). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    ActiveWorkbook.Sheets("KTO").Range("H:H"). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
On Error GoTo 0
 
End Sub
Sub bascas()
' geef de diverse commentaren een kleur

For Each cl In Sheets("NPS").Range("D2:F200")
If cl.Value <> "" Then
Select Case cl.Column
Case 4
cl.Interior.Color = 255
Case 5
cl.Interior.Color = 5296274
Case 6
cl.Interior.Color = 15773696
End Select
End If
Next

End Sub

Sub samenvoegen()
' zet het NPS commentaar recht onder elkaar met emailadres ernaast

With Sheets("Samenvoegen")
    Sheets("NPS").Range("D1:G100").Copy .Cells(1, 1)
    .Cells(1, 1).SpecialCells(4).Delete xlShiftToLeft
    .Range("A:B").ColumnWidth = 55
    .Rows.AutoFit
End With
End Sub
Sub Samenvoegen2()
' Zet de data uit KTO onder het commentaar van NPS

With Sheets("Samenvoegen")
 Sheets("KTO").Range("G2:H100").Copy .Cells(.Range("A" & .Rows.Count).End(xlUp).Row + 1, 1)
   .Cells(1, 1).SpecialCells(4).Delete xlShiftToLeft
   .Columns(1).ColumnWidth = 125
   .Cells.EntireRow.AutoFit
End With
End Sub
Sub Sorteren()
' sorteren van emailadressen

With Sheets("Samenvoegen")
    .Cells(1).CurrentRegion.Sort .Cells(1, 2), 1, , , , , , xlNo
  End With
  End Sub
  Sub Dubbel()
  'verwijder dubbele emiladressen
  With Sheets("Samenvoegen")
    lr = .Cells(Rows.Count, 2).End(xlUp).Row
      For i = lr To 2 Step -1
        If .Cells(i, 2) = .Cells(i - 1, 2) Then .Cells(i, 2).ClearContents
      Next
   End With
   End Sub
   Sub Borders()
   ' Omkader commentaar en emailadres
   With Blad1.Cells(1).CurrentRegion
      .Borders.LineStyle = xlNone
      .BorderAround , xlThin
      .AutoFilter 2, "<>"
      .Cells.SpecialCells(12).Borders(xlEdgeTop).Weight = xlThin
      .Cells.SpecialCells(12).Borders(xlInsideHorizontal).Weight = xlThin
      .AutoFilter
    End With
End Sub

Alvast bedankt

 

[Jack Nouws]

Wordt lastig zonder voorbeeld, ik zie al 4 verschillende sheets in je code.
Ik weet zo niet wat waar naar toe moet.

 

[snb]

De omkadering (wat omkaderd is) lijkt me sowieso overbodig.
Desnoods gebruik je voorwaardelijke opmaak.

 

[bascas]

Bekijk bijlage Gegevens samenvoegen kto en nps1.xls

Hierbij het voorbeeldbestand. Hoop dat jullie er wat mee kunnen.

Groet Bas

 

[Jack Nouws]

Staat de code in post 10 in volgorde van uitvoering?

 

[Cobbe]

Dat samenvoegen//ontdubbelen/sorteren kan je in een macro stoppen:

Sub samenvoegen()
' zet het NPS commentaar recht onder elkaar met emailadres ernaast
    With Sheets("Samenvoegen")
        Sheets("NPS").Range("D1:G100").Copy .Cells(1, 1)
        .Cells(1, 1).SpecialCells(4).Delete xlShiftToLeft
        .Range("A:B").ColumnWidth = 55
        .Rows.AutoFit
        ' Zet de data uit KTO onder het commentaar van NPS
        Sheets("KTO").Range("G2:H100").Copy .Cells(.Range("A" & .Rows.Count).End(xlUp).Row + 1, 1)
        .Cells(1, 1).SpecialCells(4).Delete xlShiftToLeft
        .Columns(1).ColumnWidth = 125
        .Cells.EntireRow.AutoFit
        ' sorteren van emailadressen
        .Cells(1).CurrentRegion.Sort .Cells(1, 2), 1, , , , , , xlNo
        'verwijder dubbele emiladressen
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = lr To 2 Step -1
            If .Cells(i, 2) = .Cells(i - 1, 2) Then .Cells(i, 2).ClearContents
        Next
    End With
End Sub

 

[bascas]

@Jack, ja.
@Cobbe, bedankt.
Groet Bas

 

[snb]

Maak gebruik van arrays in plaats van het werken in een werkblad.

 

[bascas]

Iedereen hartelijk bedankt voor de hulp. Ik ben eruit.
Groet Bas