< návrat zpět

MS Excel

Téma: Úprava VBA rss

Zaslal/a Veverka77 10.1.2017 18:15

Ahoj, prosím o radu. Začínám s VBA, ale pořád se motám v kruhu.

Nalezl jsem funkční kód a potřeboval bych jej doplnit o jednu jedinou funkci.
Ve zdrojových sešitech je v buňce A1 textový řetězec(obsahuje název souboru), který bych potřeboval zkopírovat do každého řádku v cílovém sešitu pro importovaná data z toho konkrétního sešitu.

Tedy zdroj bude mít v A1 uvedeno "Maso", potom každý řádek, který budu do cílového sešitu vkládat, bude mít na v prvním sloupci uvedeno Maso. Tento text mi ve výsledku rozliší, ze kterého sešitu jsem importoval. Místo tohoto řetězce by se tam klidně mohlo vkládat název souboru, ze kterého se oblast importovala, pokud by to pro kód bylo jednodušší. Tušíte někdo jak na to?

Sub Import()
Dim MsgResponse, MsgTit As String
Dim ImportFirstFile As Boolean, ImportDir As String, ImportFile As String
Dim ZdrojSoubor As Workbook, ZdrojList As Worksheet
Dim ZdrojOblast As Range, c As Range
Dim CilOblast As Range, i As Integer, j As Long, LastRowZdrojList As Long
MsgTit = "Import dat"
ImportFirstFile = True ' identifikace prvniho souboru v adresari
ImportDir = "c:UserspepaDocumentspokusy222" ' cesta k souborum

Set CilOblast = ActiveWorkbook.Worksheets("TC").Range("B2")
Application.ScreenUpdating = False
j = 0 ' ofset radku na cilovem listu
Do
If ImportFirstFile Then
On Error GoTo Err0
ImportFile = Dir(ImportDir & "*.xlsx") ' prvni soubor v adresari
On Error GoTo 0
If ImportFile = "" Then _
MsgResponse = MsgBox("Adresář souboru: '" & ImportDir _
& "' k importu je prázdný!", _
vbOKOnly + vbInformation, MsgTit): Exit Do
ImportFirstFile = False
Else
ImportFile = Dir ' dalsi soubory v adresari
End If
If ImportFile = "" Then _
MsgResponse = MsgBox("V adresáoi souboru: '" & ImportDir _
& "' k importu nejsou další soubory!", _
vbOKOnly + vbInformation, MsgTit): Exit Do
'
' MsgBox ImportFile ' pouze pro test
'
Set ZdrojSoubor = Workbooks.Open(ImportDir & "" & ImportFile) ' otevrit soubor
i = 0 ' ofset sloupcu na cilovem listu

On Error GoTo Err1
Set ZdrojList = ZdrojSoubor.Worksheets("Směr tam")
LastRowZdrojList = ZdrojList.Cells(ZdrojList.Rows.Count, 1).End(xlUp).Row
On Error GoTo 0
Set ZdrojOblast = ZdrojList.Range("A5:B" & LastRowZdrojList)
For Each c In ZdrojOblast.Cells
CilOblast.Offset(j, i).Value = c.Value


If i < 1 Then
i = i + 1 ' dalsi sloupec na cilovem listu
Else
i = 0
j = j + 1 ' dalsi radek na cilovem listu
End If
Next c
ZdrojSoubor.Close
Set ZdrojSoubor = Nothing
Loop ' dalsi soubor
Application.ScreenUpdating = True
Exit Sub
Err0:
MsgResponse = MsgBox("Chyba v zadání cesty a souboru '" & ImportDir & "" & ImportFile & "'!" _
& vbCrLf & "Bih procedury bude ukoneen!", _
vbOKOnly + vbInformation, MsgTit): Exit Sub
Err1:
MsgResponse = MsgBox("V souboru " & ImportDir & "" & ImportFile & " nebyl nalezen list1!" _
& vbCrLf & "Bih procedury bude ukoneen!", _
vbOKOnly + vbInformation, MsgTit): Exit Sub
End Sub

Děkuji za nakopnutí, případně za kód.

Veverka

Zaslat odpověď >
icon AL(10.1.2017 19:07)#034415
avatar
Ten kód je hodne prazvláštny, kopíruje bunku po bunke, ale budiž.

Skús nahradiť časť kódui = 0 ' ofset sloupcu na cilovem listu

On Error GoTo Err1
Set ZdrojList = ZdrojSoubor.Worksheets("Směr tam")
LastRowZdrojList = ZdrojList.Cells(ZdrojList.Rows.Count, 1).End(xlUp).Row
On Error GoTo 0
Set ZdrojOblast = ZdrojList.Range("A5:B" & LastRowZdrojList)
For Each c In ZdrojOblast.Cells
CilOblast.Offset(j, i).Value = c.Value

If i < 1 Then
i = i + 1 ' dalsi sloupec na cilovem listu
Else
i = 0
j = j + 1 ' dalsi radek na cilovem listu
End If
Next cza i = 1 ' ofset sloupcu na cilovem listu

On Error GoTo Err1
Set ZdrojList = ZdrojSoubor.Worksheets("LIST1")
LastRowZdrojList = ZdrojList.Cells(ZdrojList.Rows.Count, 1).End(xlUp).Row
On Error GoTo 0
Set ZdrojOblast = ZdrojList.Range("A5:B" & LastRowZdrojList)
For Each c In ZdrojOblast.Cells
If i = 1 Then CilOblast.Offset(j, 0).Value = ZdrojList.Range("A1").Value
CilOblast.Offset(j, i).Value = c.Value

If i < 2 Then
i = i + 1 ' dalsi sloupec na cilovem listu
Else
i = 1
j = j + 1 ' dalsi radek na cilovem listu
End If
Next c Pokiaľ to nebude fungovať, tak sa naučíš, že je lepšie vkladať rovno prílohu, ja ju tvoriť nebudem :)

toto pravdepodobne fungovať nebude:ImportDir = "c:UserspepaDocumentspokusy222" ' cesta k souborum
Malo by to byť pmn:"c:\UserspepaDocumentspokusy222\"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