Jeg havde overset noget, skulle være rigtig nu
Dim i As Integer ' Bruges til at hen x sider
Dim antalsider As Double
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;
http://www.Vare.dk/search.aspx?sort=El-a&type=&min=0&max=400&Hvor=" _
, Destination:=Range("A1"))
.Name = _
"search.aspx?sort=El-a&type=El&&maxHvor="
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
Rows("1:2").Delete Shift:=xlUp 'slet de 2 første linier
' Find ud af hvor mange sider
Range("B1").Select
ActiveCell.Replace What:="0-20 af ialt", Replacement:="", LookAt:=xlPart _
, SearchOrder:=xlByRows, MatchCase:=False
ActiveCell.Replace What:="boliger", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
'Range("B1").Select ' flyt antal emner 1 celle til højre
Range("B1").Copy Range("B1").offest(0, 1)
Range("A1") = "Antal sider"
Range("B1").NumberFormat = "0.00"
Range("B1").FormulaR1C1 = "=R[0]c[3]/20"
Range("C1").FormulaR1C1 = "=ROUNDUP(RC[-1],0)" ' bruges til at runde op feks. 4.11 til 5
Range("c1").Copy
'Næste 3 linie omsætter x/25 til celle 2 så det er læsebart
Range("d1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
antalsider = Range("d1").Value ' antalsider sættes til det antal der findes ved opslaget
Range("A1") = "Hvilken siden den er i gang med"
Range("d1").FormulaR1C1 = antalsider ' kun en test på hvad antalsider er sat til
With Columns("A:K") ' Opløser celle hvor postnummer er i til en enkelt celle
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Range("A2:A40").Select 'Indsætter celler for El
Selection.Insert Shift:=xlToRight
Selection.ColumnWidth = 17.71
'Range("A1").Select
'Columns("A:A").Select ' Indsætter en kolonne A
'Selection.Insert Shift:=xlToRight
Dim C As Long
Dim RW As Long
RW = Range("b3").End(xlDown).Row
For C = RW To 2 Step -1
If IsNumeric(Left(Cells(C, "B"), 1)) Then
Cells(C, "B").Copy Cells(C, "B").Offset(1, -1)
Rows(C).Delete ' Slet rækken som active cell står på
Else
Cells(C, "B").Offset(-1, -1).Copy Cells(C, "B").Offset(0, -1)
End If
Next
Range("A3:K22").Copy ' Flyt data over på ark 1
Sheets("Ark1").Select
Columns("A:B").ColumnWidth = 35
Columns("C:C").ColumnWidth = 3.29
Columns("D:D").ColumnWidth = 13.71
Columns("E:E").ColumnWidth = 6.14
Columns("F:F").ColumnWidth = 8.57
Columns("G:G").ColumnWidth = 4.29
Columns("H:H").ColumnWidth = 5.86
Columns("I:I").ColumnWidth = 4.29
Columns("J:J").ColumnWidth = 4.43
Columns("K:K").ColumnWidth = 6.1
Selection.Rows.AutoFit
Range("A2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=False
Sheets("Ark2").Select
Rows("2:37").Delete Shift:=xlUp
Columns("f:f").ColumnWidth = 10
Range("A2").Select
For i = 2 To antalsider ' xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Range("a1").Select
ActiveCell.FormulaR1C1 = i ' hvilken side skal den til at hente som står i celle A3
' Nu starter vi med side 2
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;
http://www.vare.dk/search.aspx?sort=El-a&Mål=Alle&min=0&max=400&type=El&page=" & CStr(i) _
, Destination:=Range("A1"))
.Name = _
"search.aspx?sort=El-a&Mål=Alle&min=0&max=400&type=EL&page=" & CStr(i) & q = bygget
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
Rows("2:4").Delete Shift:=xlUp 'slet de 2 første linier
With Columns("A:K") ' Opløser celle hvor El er i til en enkelt celle
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
'Indsætter celler for Arkiv
Range("A2:A40").Insert Shift:=xlToRight
Range("A2:A40").ColumnWidth = 22.71
'Range("A1").Select
Dim C1 As Long
Dim RW1 As Long
RW1 = Range("b2").End(xlDown).Row
For C1 = RW1 To 2 Step -1
If IsNumeric(Left(Cells(C1, "B"), 1)) Then
Cells(C1, "B").Copy Cells(C1, "B").Offset(1, -1)
Rows(C1).Delete ' Slet rækken som active cell står på
' Range("b2", Range("b2").End(xlDown)).Select " KABBAK" skal ikke bruges Sløver
Else
Cells(C1, "B").Offset(-1, -1).Copy Cells(C1, "B").Offset(0, -1)
End If
Next
Range("A2:K22").Copy ' Flyt data over på ark 1
Sheets("Ark1").Select
'Range("A2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=False
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Sheets("Ark2").Select
Rows("1:37").Delete Shift:=xlUp
Columns("f:f").ColumnWidth = 17.71
Range("A2").Select
Next i
ActiveWorkbook.Save
Ny bruger
Nybegynder
Opret
Preview
