< návrat zpět

MS Excel


Téma: Uprava makra import www rss

Zaslal/a 30.12.2012 17:45

Dobrý den,
chtěl bych poprosit o upravu makra z tohoto tematu
http://wall.cz/index.php?m=topic&id=8588
Poki to tam krásně vyřešil, ale ja bych potřeboval jemnou upravu a to aby se nevytvářeli další listy ale vytvořil se jeden nový list a do něj by se ty data kopírovaly pod sebe.
Nevíte prosím někdo ?
Děkuji moc.

Zaslat odpověď >

#010811
avatar
Zde dávám ten kod:

Sub import_cyklus()
Dim i As Long, Sloupec As Long

Sloupec = 1 'sloupec E

For i = 2 To Worksheets("UVOD").Cells(1000000, Sloupec).End(xlUp).Row

ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "tým " & Worksheets("UVOD").Cells(i, Sloupec)

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.peloton.cz/soutez?tym=" & Worksheets("UVOD").Cells(i, Sloupec), Destination:=Range("$A$1"))
.Name = "soutez?tym=" & Worksheets("UVOD").Cells(i, Sloupec)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next i
End Sub



Co mám změnit, aby to fungovalo tak jak jsem psal výše?citovat
icon #010813
avatar
Budeš musieť inštrukciu

ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)

predsadiť pred ten cyklus For-Next

V cykle For-Next potom pre každú QueryTable určiť, kam sa má vložiť jej prvá bunka, t.j. zistiť najprv prvý prázdny riadok (bunku) na tom liste, do ktorého sa majú jednotlivé QueryTables vkladať.citovat
#010834
avatar
Ten původní dotaz jsem posílal já. Od té doby jsem si trochu posunul level (v Excelu). 3
Předpokládám, že ten cyklus budeš chtít použít na nějaké vlastní www adresy.
Je důležité zjistit, ve kterém sloupci je "hlavní" obsah načtených dat.
Ten se může měnit podle toho, zda se importuje celá stránka nebo jen vybrané tabulky (označené šipkama v okně importu). Podle toho "hlavního sloupce" se pak dá určit poslední řádek pro vkládání dat pod sebe.
Dál je nutné v úseku With - End With zaměnit řádek .RefreshStyle tak, aby importovaná data šly pod sebe.
Já importuju kde co a často taky chci jen jednorázová data, bez uloženého webového dotazu. Dráždí mě pak, že Excel otravuje s možností aktualizace dat po načtení souboru. Pro to mám v cyklu řádek, kdy se právě uložený web dotaz smaže. Předpoklad je, že v sešitu nejsou žádné další web dotazy, které chceš ponechat. Pak se dá taky na řádek .Name dát cokoliv, třeba "aaaaa".
V kódu je tenhle řádek zapoznámkovaný - je to jen možnost, data budou importovaná na aktuální list (prázdný, jiný než UVOD - s tím se dá ještě taky pohrát, založit si nový, přejmenovat atd., to tam ale není).
Sub import_cyklus()
Dim i As Long, Sloupec As Long
Sloupec = 1 ' zde soucasne sl. na UVOD pro brani www adres a kontrolovaný sl. pro posl.radek
For i = 2 To Worksheets("UVOD").Cells(Rows.Count, Sloupec).End(xlUp).Row
adresa = "$A$" & Cells(Rows.Count, sloupec).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.peloton.cz/soutez?tym=" _
& Worksheets("UVOD").Cells(i, Sloupec), Destination:=Range(adresa))
.Name = "soutez?tym=" & Worksheets("UVOD").Cells(i, Sloupec)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertEntireRows
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage ' zde import cele stranky
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
' ActiveWorkbook.Connections(1).Delete
Next i
End Sub

Tento kód jsem ale netestoval, zkoušel jsem jen části a s jinou www.citovat
#010840
avatar
Ještě pokračování. Vyzkoušel jsem celek, funguje mi na 2010CZ. Tímto se omlouvám tvůrcům v testu stahovaných www, snad jim to nezahltí server.
Příloha: zip10840_test-importu-v-cyklu.zip (16kB, staženo 32x)
citovat
#010842
avatar
Ohromné Díky!
Funguje to skvěle!citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje