< návrat zpět

MS Excel

Téma: Dynamicky pojmenovaná oblast rss

Zaslal/a jardysek 6.11.2014 20:01

Mám tabulku, kde vedu údaje o spotřebě nafty. List má název Megan. Pro aktualizaci dat v KT jsem použil pojmenovanou oblast s odkazem: =NEPŘÍMÝ.ODKAZ("megan!$b$3:$g$"&POČET2(Megan!$B:$B)).
V ř. č.3 je záhlaví tabulky a dále následují data.Do oblasti se nezapočítávají údaje na posledních dvou řádcích. Pokud doplním další data, zahrnou se do odkazu zase kromě posledních dvou řádků. Nevím, kde mám chybu.

Zaslat odpověď >
Strana:  « předchozí  1 2 3 4 5   další »
icon eLCHa(20.5.2015 9:13)#025034
eLCHa
Tak změna - hned jak jsem to odeslal, tak mně napadlo jak odbourat druhý cyklus ;)

samotné načtení a zápis dat trvá u mně cca 2 s, zbytek času si bere excel na doplnění vzorců, kalkulace atd

Sub subImportCSV()
Dim sFileTemp As String
sFileTemp = Dir(ThisWorkbook.Path & "\*.csv")

Dim sFile As String, dFileTime As Date
While Not sFileTemp = vbNullString
If FileDateTime(ThisWorkbook.Path & "\" & sFileTemp) > dFileTime Then
sFile = ThisWorkbook.Path & "\" & sFileTemp
End If
sFileTemp = Dir
Wend

If Not sFile = vbNullString Then
Dim sText As String
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sFile)
sText = .ReadAll
.Close
End With 'CreateObject("Scripting.FileSystemObject").OpenTextFile(sFile)

Dim iRows As Long
iRows = (Len(sText) - Len(Replace(sText, vbCrLf, vbNullString))) / 2

With CreateObject("Scripting.FileSystemObject").OpenTextFile(sFile)

Dim vValues() As Variant
ReDim vValues(iRows, UBound(Split(.ReadLine, ";"))) 'záhlaví

Dim iRow As Long, iColumn As Long
iRow = -1
Dim sLine As String
While Not .AtEndOfStream
iRow = iRow + 1
sLine = .ReadLine
For iColumn = 0 To UBound(vValues, 2)
vValues(iRow, iColumn) = Split(sLine, ";")(iColumn)
Next iColumn
Wend
.Close

End With 'CreateObject("Scripting.FileSystemObject").OpenTextFile(sFile)

With ActiveSheet.ListObjects("DataTab").DataBodyRange
If .Rows.Count > 1 Then
.Offset(1, 0).EntireRow.Delete
End If
.Cells(1).Resize(UBound(vValues, 1) + 1, UBound(vValues, 2) + 1).Value = vValues
End With 'ActiveSheet.ListObjects("DataTab").DataBodyRange
Else
MsgBox ("Neexistuje žiadny .csv súbor.")
End If
End Subcitovat
icon eLCHa(20.5.2015 9:22)#025036
eLCHa
@Alfan
pokud exportujete soubor do xml a následně ho ručně transforujete na csv přičemž csv pak importujete kódem, nechte kód, ať to udělá za Vás ;)citovat
icon eLCHa(20.5.2015 9:36)#025038
eLCHa
Mno a když už si tak povídám ))
Závity jsem pocvičil, se svým řešením jsem spokojen. Nicméně nejjednodušší prostě bude csv otevřítSub subImportCSV()
Dim sFileTemp As String
sFileTemp = Dir(ThisWorkbook.Path & "\*.csv")

Dim sFile As String, dFileTime As Date
While Not sFileTemp = vbNullString
If FileDateTime(ThisWorkbook.Path & "\" & sFileTemp) > dFileTime Then
sFile = ThisWorkbook.Path & "\" & sFileTemp
End If
sFileTemp = Dir
Wend

If Not sFile = vbNullString Then
Dim bScreen As Boolean
bScreen = Application.ScreenUpdating
Application.ScreenUpdating = False

Workbooks.OpenText Filename:=sFile, DataType:=xlDelimited, Semicolon:=True, Local:=True
With ActiveWorkbook
With .Worksheets(1).UsedRange
Dim vValues As Variant
vValues = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
End With '.Worksheets(1).UsedRange
.Close False
End With 'ActiveWorkbook

With ActiveSheet.ListObjects("DataTab").DataBodyRange

If .Rows.Count > 1 Then
.Offset(1, 0).EntireRow.Delete
End If
.Cells(1).Resize(UBound(vValues, 1), UBound(vValues, 2)).Value = vValues

End With 'ActiveSheet.ListObjects("DataTab").DataBodyRange

Application.ScreenUpdating = bScreen
Else
MsgBox ("Neexistuje žiadny .csv súbor.")
End If
End Subcitovat
Alfan(20.5.2015 11:54)#025042
Alfan
To eLCHa
add 1) Spustil jsem byla chyba na tomto řádku:
With ActiveSheet.ListObjects("DataTab").DataBodyRange
Tak jsem spustil makro přímo z listu a proběhlo to.
Já mám totiž na listu "aktualizace" připravená tlačítka, ke kterým přiřazuji makra a tam spouštím to, co potřebuji. Šlo by to makro upravit, aby šlo spustit odkudkoliv?
Ale načetlo mi to o jeden řádek méně. Já totiž od rána mám smazána záhlaví a tak mi data začínají od řádku 1.
Nicméně při exportu z účetního SW začínají data o řádku 3, protože je tam v prvním řádku nějaká info, jen v jedné buňce a v druhém řádku jsou záhlaví sloupců.

add 2) Já ten exportovaný soubor XML mám vždy stejně otevřený hned po exportu v excelu (udělá se to automaticky) a pak ho musím někam uložit a při té příležitosti buď mohu umazat jen jeden (1.) řádek nebo první dva řádky. Ale podle makra bych umazal jen ten první.

add 3) Tady v tom řádku
sFileTemp = Dir(ThisWorkbook.Path & "\*.csv")
dá se upravit cesta k tomu *.CSV souboru?
Teď je to nastavené, že je *.CSV ve stejném adresáři.
Kdybych dal do stejného adresáře adresář "DATA" bylo by to takto?
sFileTemp = Dir(ThisWorkbook.Path & ".\DATA\*.csv")
nebo jen takto?
sFileTemp = Dir(ThisWorkbook.Path & "DATA\*.csv")

Děkujicitovat
icon eLCHa(20.5.2015 12:12)#025043
eLCHa
MístoWith ActiveSheet.ListObjects("DataTab").DataBodyRangedejteWith Worksheets("NazevListu").ListObjects("DataTab").DataBodyRange
Nicméně při exportu z účetního SW začínají data o řádku 3, protože je tam v prvním řádku nějaká info, jen v jedné buňce a v druhém řádku jsou záhlaví sloupců.
Nejsem si jistý, jestli dobře rozumím. Pro soubor s info+záhlaví nahraďte
vValues = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Valueza
vValues = .Offset(2, 0).Resize(.Rows.Count - 2, .Columns.Count).Value

sFileTemp = Dir(ThisWorkbook.Path & "\DATA\*.csv")a pak ještě nahradit oba výskytyThisWorkbook.Path & "\" & sFileTempzaThisWorkbook.Path & "\DATA\" & sFileTempcitovat
Alfan(20.5.2015 12:57)#025044
Alfan
Tak jsem upravil na hlásí to chybu:
"Subscript out of range" na tomto řádku
With Worksheets("makra").ListObjects("DataTab").DataBodyRange
List, na kterém mám ta tlačítka se jmenuje "makra"

Tohle je celý kod:
Sub subImportCSV_RBR()

Dim sFileTemp As String

sFileTemp = Dir(ThisWorkbook.Path & "\DATA\*.csv")
'sFileTemp = Dir(ThisWorkbook.Path & "\*.csv") 'když je uloženo ve stejném adresáři



Dim sFile As String, dFileTime As Date

While Not sFileTemp = vbNullString

If FileDateTime(ThisWorkbook.Path & "\DATA\" & sFileTemp) > dFileTime Then

sFile = ThisWorkbook.Path & "\DATA\" & sFileTemp

'If FileDateTime(ThisWorkbook.Path & "\" & sFileTemp) > dFileTime Then 'když je uloženo ve stejném adresáři

'sFile = ThisWorkbook.Path & "\" & sFileTemp 'když je uloženo ve stejném adresáři


End If

sFileTemp = Dir

Wend



If Not sFile = vbNullString Then

Dim bScreen As Boolean

bScreen = Application.ScreenUpdating

Application.ScreenUpdating = False

Workbooks.OpenText Filename:=sFile, DataType:=xlDelimited, Semicolon:=True, Local:=True

With ActiveWorkbook

With .Worksheets(1).UsedRange

Dim vValues As Variant

vValues = .Offset(2, 0).Resize(.Rows.Count - 2, .Columns.Count).Value

'vValues = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value 'začíná číst data ze zdroje od třetího řádku, první dva jsou záhlaví

End With '.Worksheets(1).UsedRange

.Close False

End With 'ActiveWorkbook


With Worksheets("makra").ListObjects("DataTab").DataBodyRange
'With ActiveSheet.ListObjects("DataTab").DataBodyRange 'muselo by se makro spouštět přímo z listu "DataTab"



If .Rows.Count > 1 Then

.Offset(1, 0).EntireRow.Delete

End If

.Cells(1).Resize(UBound(vValues, 1), UBound(vValues, 2)).Value = vValues



End With 'ActiveSheet.ListObjects("DataTab").DataBodyRange



Application.ScreenUpdating = bScreen


Else

MsgBox ("Neexistuje žiadny .csv súbor.")

End If

End Sub
citovat
icon eLCHa(20.5.2015 13:07)#025045
eLCHa
Vy ale nevkládáte ta data na list makra ale na jiný list. Patří tam název listu, kde je ta tabulka.citovat
Alfan(20.5.2015 13:31)#025046
Alfan
Jj, už to funguje, jsem lama 1

Pokud jsem to dobře pochopil, tak se to dá využít pro jakoukoliv tabulku, kterou pojmenuji DataTab nebo bych případně musel zeditovat její název v makru.
Ale nezáleží, jak bude veliká respektive, kolik bude mít sloupců.
Důležité je, aby připravená tabulka vždy využívala zdrojová data *.csv se stejným počtem sloupců, se kterým byla vytvořená tabulka.
Případně bych musel tabulku převést zpět na rozsah, dle potřeby doplnit sloupce, výpočtové a na data a pak zase zpět převést na tabulku.
A vždy musí být sloupce s daty a pak až následovat sloupce s výpočty.

Jinak mi celé načtení a přepočet trvá cca 20 sekund při cca 103 000 zdrojových řádcích.

A ještě jeden dotaz na konec. To makro lze takto připravit jen pro *.csv nebo to lze připravit i pro *.xml?citovat
icon eLCHa(20.5.2015 13:42)#025047
eLCHa
Případně bych musel tabulku převést zpět na rozsah, dle potřeby doplnit sloupce, výpočtové a na data a pak zase zpět převést na tabulku.
Nemusíte převádět na rozsah - klikněte pravým tlačítkem a můžete odstranit nebo vložit sloupce

A vždy musí být sloupce s daty a pak až následovat sloupce s výpočty.
ano - vzorce nakonec

To makro lze takto připravit jen pro *.csv nebo to lze připravit i pro *.xml?
Lze téměř cokoliv...
Ale to už nechám na někom jiném

jen technická
začátek si upravte takto - kdybyste měnil adresář, uděláte to na jednom místě Dim sDir As String
sDir = ThisWorkbook.Path & "\DATA\"

Dim sFileTemp As String
sFileTemp = Dir(sDir & "\*.csv")
Dim sFile As String, dFileTime As Date
While Not sFileTemp = vbNullString
If FileDateTime(sDir & sFileTemp) > dFileTime Then
sFile = sDir & sFileTemp
End If
sFileTemp = Dir
Wendcitovat
Alfan(20.5.2015 14:42)#025049
Alfan
Mockrát děkuju 1
Upravil jsem to.citovat

Strana:  « předchozí  1 2 3 4 5   další »

Uživatelské menu

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

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura IV

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

Aktivní diskuse

Vynásobit hodnoty kurzem - Power Query

Alfan • 26.4. 7:56

Relativní cesta - zdroje Power Query

Alfan • 26.4. 7:54

Vynásobit hodnoty kurzem - Power Query

elninoslov • 26.4. 7:54

Vynásobit hodnoty kurzem - Power Query

lubo • 25.4. 19:18

Relativní cesta - zdroje Power Query

elninoslov • 25.4. 15:12

Relativní cesta - zdroje Power Query

Alfan • 25.4. 15:08

Relativní cesta - zdroje Power Query

elninoslov • 25.4. 14:21