Hej Steffen
Prøv nedenstående, som plaseres i et modul (Alt + F11)
Da du, som du skriver, er "ny" har jeg tilladt mig at sende dig en zippet
excelfil med makroen.
Herved undgår vi måske en hel del spørgsmål.
Du er naturligvis altid velkommen til at kontakte mig gennem denne NG.
Jeg er IKKE online og heller IKKE på nettet hver dag, beklager.
Option Explicit
''
''**************************************************************************
*
'' Purpose : help 2 Steffen
'' Written : 16-maj-2003 by Joergen Bondesen
''
Const Hej As String = "Hilsen fra Jørgen"
Sub delxrows()
'Empty sheet
Dim SheetsCount As Long
SheetsCount = Application.WorksheetFunction.CountA(Cells)
If SheetsCount = 0 Then
MsgBox "Sheet er tomt, makro afbrydes.", vbCritical, Hej
Exit Sub
End If
'Startrække
Dim StrStartrow As Integer
StrStartrow = 1
Range("A" & StrStartrow).Select
StrStartrow = Application.InputBox("Vælg venligst en celle" _
& " i Startrækken.", Hej, "A" & StrStartrow, , , , , 8)
If StrStartrow = 0 Then Exit Sub
'Antal rækker der skal slettes
Dim NoOfRowdel As Integer
NoOfRowdel = 49
NoOfRowdel = Application.InputBox("Indtast venligst antal" _
& " rækker der skal slettes.", Hej, NoOfRowdel, , , , , 1)
If NoOfRowdel = 0 Then Exit Sub
Dim Lastrow As Long
Lastrow = Range("A65536").End(xlUp).Row
'Sluttrække
Dim StrEndrow As Integer
Range("A" & Lastrow).Select
StrEndrow = Application.InputBox("Vælg venligst en celle" _
& " i Slutrækken." & vbCr & vbCr & "Efterfølgende rækker bliver
slettet.", Hej, "A" & Lastrow, , , , , 8)
If StrEndrow = 0 Then Exit Sub
Range("A" & StrStartrow).Select
Dim NoOfRows As Long
NoOfRows = StrEndrow - StrStartrow + 1
If NoOfRows = 1 Then
MsgBox "Der er INGEN forskel mellem start- og slutrække." _
& " Makro afbrydes.", vbCritical, Hej
Exit Sub
End If
Dim testlastrow As Long
testlastrow = NoOfRows Mod (NoOfRowdel + 1)
If testlastrow <> 0 Then
Dim Retest As String
Retest = MsgBox("Du har " & testlastrow _
& " rækker tilbage, <> " & NoOfRowdel & ". Ønsker du at bevare ""række
"" " _
& testlastrow & ", dvs. den sidste række?", _
vbCritical + vbYesNoCancel + vbDefaultButton1, Hej)
If Retest = vbCancel Then Exit Sub
End If
Application.ScreenUpdating = False
'Del rows under last row
Rows(StrEndrow + 1 & ":65536").EntireRow.Delete Shift:=xlUp
Dim a As Variant
Dim Ansver As Long
Ansver = Application.WorksheetFunction.Floor(NoOfRows / (NoOfRowdel + 1),
1)
Dim one As Integer
If Retest = vbNo Then
Ansver = Ansver + 1
one = -1
End If
If Retest = vbYes Then one = 1
For a = 1 To Ansver
Rows(StrStartrow + a - 1 & ":" _
& NoOfRowdel + a - 2 + StrStartrow).EntireRow.Delete Shift:=xlUp
Application.StatusBar = "Running: " & a + one & " of " & Ansver + one
Next a
If Retest = vbYes Then
Rows(StrStartrow + a - 1 & ":" _
& a + testlastrow - 3 + StrStartrow).EntireRow.Delete Shift:=xlUp
End If
Application.StatusBar = Application.StatusBar & " Finito: " & Now
End Sub
Med venlig hilsen
Jørgen Bondesen
"Steffen H.Schmidt" <vw83gti@hotmail.com> wrote in message
news:3ec34fc5$0$24669$edfadb0f@dread14.news.tele.dk...
> Hej NG
>
> Jeg har nogle store datasæt (ascii filer med 65000 datapar) som jeg gerne
> vil fjerne 49 for hver 50 datapar af.
> (Sampling raten var meget højere end nødvendigt.)
>
> Det er nemt at optage en macro der vælger 49 rows, deleter og rykker op,
og
> så går en celle ned. Men hvordan får jeg den til at gentage sig selv
indtil
> den er nede i bunden af arket ?
>
> Jeg har prøvet at trykke shortcut til macroen selv, under optagelsen af
> macroen, men det går galt med stack overflow eller noget lign når man så
> kører den. Det er vist ikke den rigtige måde at lave en løkke på.
>
> Jeg aner intet om VBA
>
> Er der nogen der kan hjælpe ?
>
> Med venlig hilsen
>
> Steffen
> Sønderborg
>
>
|