Forum strony www.multipasko.pl [Regulamin]


Dodaj wpis w tym temacie
Spis tematów
Login:

Hasło:
Strona: 1
Wyślij wiadomość do admina

Przewiń wpisy ↓

Pobierania wyników losowań Mini

2017-05-03 (10:56)

status slawek001
Data rejestracji: 2005-02-24 00:00:00
Ilość postów: 6116

721
wpis nr 1 077 701
[ CZCIONKA MONOSPACE ]

Makro do pobierania wyników losowań Mini kod:



Sub Losowania_Mini()

Application.ScreenUpdating = False



Dim ost_k As Long, i As Long, ost_w As Long, ile As Long, X As Long

Dim wsk As Byte, pom As Byte

Dim Tabela As Variant



Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual



With Sheets("Arkusz1")

ost_k = .Cells(1, .Columns.Count).End(xlToLeft).Column

For i = ost_k To 1 Step -1

.Columns(i).Delete

Next i



With Sheets("Arkusz1").QueryTables.Add(Connection:="URL;https://www.multipasko.pl/wyniki-csv.php?f=minilotto-sortowane", _

Destination:=Sheets("Arkusz1").Range("a1"))



.Name = "ml_1"

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.BackgroundQuery = True

.RefreshStyle = xlInsertDeleteCells

.SavePassword = False

'.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.WebSelectionType = xlAllTables

.WebFormatting = xlWebFormattingNone

.WebPreFormattedTextToColumns = True

.WebConsecutiveDelimitersAsOne = True

.WebSingleBlockTextImport = False

.WebDisableDateRecognition = False

.WebDisableRedirections = False

.Refresh BackgroundQuery:=False

.SaveData = True

End With



.Rows(1).Delete

ile = .Cells(Rows.Count, "A").End(xlUp).Row



Tabela = .Range("A1:A" & ile).Value

On Error GoTo koniec:

For i = 1 To ile

Tabela(i, 1) = Replace(Tabela(i, 1), ";", ". ", 1, 1)

Tabela(i, 1) = Replace(Tabela(i, 1), ";", ".", 1, 2)

Next i

On Error GoTo 0

.Range("A1:A" & ile).Value = Tabela



.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _

Semicolon:=True, Comma:=True, Space:=True, Other:=False, OtherChar:= _

".", FieldInfo:=Array(Array(1, 1), Array(2, 4), Array(3, 1), Array(4, 1), Array(5, 1), _

Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1) _

, Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array( _

19, 1), Array(20, 1), Array(21, 1), Array(22, 1)), TrailingMinusNumbers:=True

.Columns("A:A").Replace What:=".", Replacement:="", LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

ReplaceFormat:=False

.Cells.EntireColumn.AutoFit



Erase Tabela

Tabela = .Range("C1:V" & ile).Value

ost_w = .Cells(.Rows.Count, 1).End(xlUp).Row

ost_k = .Cells(1, .Columns.Count).End(xlToLeft).Column



Range(.Cells(4424, 3), .Cells(ost_w, ost_k)).Copy

Sheets("Arkusz1").Range("BM1").PasteSpecial Paste:=xlPasteValues



For i = 1 To ile

Do

wsk = 0

For X = 1 To 20 - 1

If Tabela(i, X + 1) < Tabela(i, X) Then

wsk = 1

pom = Tabela(i, X)

Tabela(i, X) = Tabela(i, X + 1)

Tabela(i, X + 1) = pom

End If

Next X

Loop Until wsk = 0

Next i



.Range("C1:V" & ile).Value = Tabela





Range(.Cells(4424, 3), .Cells(ost_w, ost_k)).Copy

Sheets("Arkusz1").Range("AA1").PasteSpecial Paste:=xlPasteValues

.Cells.QueryTable.Delete

End With





Erase Tabela



With Application

.ScreenUpdating = True

.Calculation = xlCalculationAutomatic

.CutCopyMode = False



End With



MsgBox "Aktualizacja zakończona."

Exit Sub



koniec:



With Application

.ScreenUpdating = True

.Calculation = xlCalculationAutomatic

.CutCopyMode = False

End With

Worksheets("Arkusz1").Cells.QueryTable.Delete

MsgBox "Aktualizacja obecnie niemożliwa", vbExclamation

ActiveSheet.Shapes("Button 1").Select

Selection.OnAction = "aktualizuj"

Range("AO11").Select

ActiveWorkbook.RunAutoMacros Which:=xlAutoClose



Application.ScreenUpdating = True



End Sub





Arkusz1 jest to przerobiona Kwarenda zawartość danych arkusza jest „czyszczona”, dlatego zalecam przenoszenie wyników losowań do innego arkusza.



W celu automatycznego pobierania wyników losowań podczas otwierania arkusza wchodzimy w kod VBA i w module głównym ThisWorkbook wstawiamy kod:



Private Sub Workbook_Open()

[Losowania_Mini]

End Sub



Od teraz przy każdym uruchomieniu arkusza będą pobierane wyniki losowań.

| Dodaj wpis w tym temacie | Spis tematów | Wyniki lottoStrona: 1
Wyślij wiadomość do admina