Hur raderar man rader i VBA - Excel ordentligt?

[Locutus]

Jag har en VBA kod som formaterar ett exceldokument (en lång lista, där endast vissa rader ska behållas beroende på nummer i första kolumnen).

När jag använder följande kod, så plockas rätt rader ut, men det blir en massa rader kvar under som är tomma, men räknas in i dokumentet och då blir radhöjden fel, när jag formaterar listan för utskrift.

Det jag vill göra är att radera alla rader förutom de jag plockat ut. Går det?

 

Sub TaUtRumA()

Dim rng As Range, cell As Range, del As Range

Set rng = Intersect(Range("A1:A200"), ActiveSheet.UsedRange)
For Each cell In rng
   If (cell.Value) < 11 Or (cell.Value) >= 16 Then
       If del Is Nothing Then
           Set del = cell
       Else: Set del = Union(del, cell)
       End If
   End If
Next cell
On Error Resume Next
del.EntireRow.Delete

End Sub

Tillägg: Så här ser listan ut från början:

Så här ska den se ut:

Men så här blir det:

[Monshi]

Din kod raderar det du vill men du vill formatera det du har kvar på rätt vis.

 

Lägg till lite kod som ser till att sätta rätt radhöjd på dina kvarvarande data.

[Locutus]

Din kod raderar det du vill men du vill formatera det du har kvar på rätt vis.

 

Lägg till lite kod som ser till att sätta rätt radhöjd på dina kvarvarande data.

 

OK, jag får titta vidare på det. Saken är den att om jag raderar raderna manuellt _innan_ jag kör formateringskoden, så blir det helt rätt, det var därför jag tänkte att jag gjort något fel i kodsnutten som hämtar ut raderna åt mig som jag nyligen lade till. Om du vill kan jag posta hela koden som jag har.

[Monshi]

Koden du har gör samma som om du manuellt markerar alla de celler i A som innehåller värden enligt dina kriterier, högerklickar och väljer radera hela raden.

 

De raderna raderas då och övriga förblir opåverkade.

 

Du har kod som ska formatera det? Men den fungerar inte när koden körts men när du gjort samma manuellt?

[Locutus]

Koden du har gör samma som om du manuellt markerar alla de celler i A som innehåller värden enligt dina kriterier, högerklickar och väljer radera hela raden.

 

De raderna raderas då och övriga förblir opåverkade.

 

Du har kod som ska formatera det? Men den fungerar inte när koden körts men när du gjort samma manuellt?

 

Ja, helt riktigt. Så det blev något galet när jag la till kodsnutten som plockar ut raderna automatiskt (med en UserForm och radioknappar).

 

Här är all kod:

Dim Valt As String

Private Sub Btn_Starta_Click()
If Opt_EVAA.Value = True Then
   MsgBox "Valt EVA A"
   Valt = "A"
   AllaSidor
ElseIf Opt_EVAB.Value = True Then
   MsgBox "Valt EVA B"
   Valt = "B"
   AllaSidor
ElseIf Opt_EVAC.Value = True Then
   MsgBox "Valt EVA C"
   Valt = "C"
   AllaSidor
ElseIf Opt_EVAAB.Value = True Then
   MsgBox "Valt EVA AB"
ElseIf Opt_EVACA.Value = True Then
   MsgBox "Valt EVA CA"
ElseIf Opt_HIA.Value = True Then
   MsgBox "Valt HIA"
Else
   MsgBox "Välj en sida att skriva ut"
End If


End Sub


Sub AllaSidor()


Application.ScreenUpdating = False

' Aktivera fönstret som skall formateras, typ:
'ActiveWindow.ActivatePrevious

' Alla sidor med linjer
' Använder variabeln a från rumsnummerkoden att avgöra hur många linjer med
' text det finns och väljer utskriftsområde utifrån det



' Ta bort onödiga rader och kolumner
   Columns("A:A").Select
   Selection.Delete shift:=xlToLeft
   Rows("1:1").Select
   Selection.Delete shift:=xlUp
   Columns("C:C").Select
   Selection.Delete shift:=xlToLeft
   Columns("G:J").Select
   Selection.Delete shift:=xlToLeft

' Namnge celler
' *** Startnummer för rumsnummer (A1) ***
CurrNum = Cells(1, 1).Value
a = 1         ' *** Hänvisning till radnummer att starta på ***
Do
   ' *** Om rutan är tom ***
   If Cells(a, 1).Value = "" Then
       Cells(a, 1).Value = CurrNum  ' *** Lägg till rumsnummer att skriva ut ***
       CurrNum = Cells(a, 1).Value   ' *** Lägg till en ny siffra i rumnsummervariabeln ***
   Else
   ' *** Om rutan har en siffra i sig (rumsnr), Lägg till den i rumsnr variabeln ***
       CurrNum = Cells(a, 1).Value

   End If

   ' Skriva sekr i Kolumn C
   If Cells(a, 3).Value = "J" Then
       Cells(a, 3).Value = "Sekr"
   End If

   a = a + 1

       ' *** Kör så länge rutan till höger (sängnr) inte är tom ***
Loop While Cells(a, 2).Value <> ""

If Valt = "A" Then
   TaUtRumA
ElseIf Valt = "B" Then
   TaUtRumB
ElseIf Valt = "C" Then
   TaUtRumC
End If

UserForm1.Hide

' Kolumnbredd
   Columns("A:F").EntireColumn.AutoFit
   Columns("C:C").Select
   Selection.ColumnWidth = 5
   Columns("E:E").Select
   Selection.ColumnWidth = 60
   'Columns("I:I").ColumnWidth = 11.86
   'Columns("H:I").ColumnWidth = 18

' Radlinjer
   Range("1:" & a).Select
   Selection.Borders(xlDiagonalDown).LineStyle = xlNone
   Selection.Borders(xlDiagonalUp).LineStyle = xlNone
   Selection.Borders(xlEdgeLeft).LineStyle = xlNone
   With Selection.Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   With Selection.Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   Selection.Borders(xlEdgeRight).LineStyle = xlNone
   Selection.Borders(xlInsideVertical).LineStyle = xlNone
   With Selection.Borders(xlInsideHorizontal)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   With Selection
       .HorizontalAlignment = xlGeneral
       .VerticalAlignment = xlTop
       .WrapText = True
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With



' Radhöjd
   If a < 10 Or a > 25 Then
           Range(Cells(1, 1), Cells(a - 1, 1)).Select
           Selection.RowHeight = (700 / (a - 1))
   Else
       Range(Cells(1, 1), Cells(a - 1, 1)).Select
       Selection.RowHeight = (1400 / (a - 1))

   End If


' Marginaler
   With ActiveSheet.PageSetup
       .LeftHeader = ""
       .CenterHeader = ""
       .RightHeader = ""
       .LeftFooter = ""
       .CenterFooter = ""
       .RightFooter = ""
       .LeftMargin = Application.InchesToPoints(3.93700787401575E-02)
       .RightMargin = Application.InchesToPoints(3.93700787401575E-02)
       .TopMargin = Application.InchesToPoints(0.5)
       .BottomMargin = Application.InchesToPoints(0.5)
       .HeaderMargin = Application.InchesToPoints(0)
       .FooterMargin = Application.InchesToPoints(0)
       .PrintHeadings = False
       .PrintGridlines = False
       .PrintComments = xlPrintNoComments
       .PrintQuality = 600
       .CenterHorizontally = False
       .CenterVertically = False
       .Orientation = xlPortrait
       .Draft = False
       .PaperSize = xlPaperA4
       .FirstPageNumber = xlAutomatic
       .Order = xlDownThenOver
       .BlackAndWhite = False
       .Zoom = 100
   End With

Application.ScreenUpdating = True
'
' DateTimestamp Makro

'
   Rows("1:1").Select
   Selection.Insert shift:=xlDown
   Range("C1:G1").Select
   With Selection
       .HorizontalAlignment = xlCenter
       .VerticalAlignment = xlBottom
       .WrapText = False
       .Orientation = 0
       .AddIndent = False
       .IndentLevel = 0
       .ShrinkToFit = False
       .ReadingOrder = xlContext
       .MergeCells = False
   End With
   Selection.Merge
   Selection.Value = Now()
   Selection.Font.Bold = True

' Utskriftområde
   'ActiveSheet.PageSetup.PrintArea = "$A$1:$I$" & a
   ActiveSheet.PageSetup.PrintArea = "$A$1:$F$" & a

End Sub


Sub TaUtRumA()

Dim rng As Range, cell As Range, del As Range
'Set rng = Intersect(Range("A1:C20"), ActiveSheet.UsedRange)
Set rng = Intersect(Range("A1:A200"), ActiveSheet.UsedRange)
For Each cell In rng
   'If (cell.Value) < 11 Or (cell.Value) > 15

   If (cell.Value) < 11 Or (cell.Value) >= 16 Then
       If del Is Nothing Then
           Set del = cell
       Else: Set del = Union(del, cell)
       End If
   End If
Next cell
On Error Resume Next
del.EntireRow.Delete

End Sub
Sub TaUtRumB()

Dim rng As Range, cell As Range, del As Range
'Set rng = Intersect(Range("A1:C20"), ActiveSheet.UsedRange)
Set rng = Intersect(Range("A1:A200"), ActiveSheet.UsedRange)
For Each cell In rng
   If (cell.Value) < 16 Or (cell.Value) > 19 Then
       If del Is Nothing Then
           Set del = cell
       Else: Set del = Union(del, cell)
       End If
   End If
Next cell
On Error Resume Next
del.EntireRow.Delete

End Sub

Sub TaUtRumC()

Dim rng As Range, cell As Range, del As Range
'Set rng = Intersect(Range("A1:C20"), ActiveSheet.UsedRange)
Set rng = Intersect(Range("A1:A200"), ActiveSheet.UsedRange)
For Each cell In rng
   If (cell.Value) < 7 Or (cell.Value) > 10 Then
       If del Is Nothing Then
           Set del = cell
       Else: Set del = Union(del, cell)
       End If
   End If
Next cell
On Error Resume Next
del.EntireRow.Delete

End Sub

 

tillägg: Jag ser nu att jag möjligen använder samma variabel (a) som räknar alla rader från början senare i dokumentet i formateringen. Kan vara så att det är det som spökar. Jag kollar vidare på det.

 

Tack

[Monshi]

Variabler - se till att ALLTID deklarera dina variabler. Lägg till raden Option Explicit först i din modul.

 

För att se till att detta alltid krävs, öppna Verktyg - > Alternativ i VBA-editorn

 

samt läs

//eforum.idg.se/topic/220943-riktlinjer-for-bra-vba-kod/

för lite mer råd om hur du bör utforma kod. Exempelvis Select/Selection ska användas så lite det bara går!

 

Exempelvis skriv inte som

 Columns("A:A").Select
Selection.Delete shift:=xlToLeft

Utan snarare

With Blad1
  .Columns("A:A").Delete shift:=xlToLeft
  .Rows("1:1").Delete shift:=xlUp
End With

Select ska ENBART användas om du behöver visa användaren något.

 

I övrigt, svårt att se i koden vad du gör fel men testa att namnge variablerna lite bättre. a? Lite bättre kan du :-)

 

Flyttar tråden till VBA