VBA - prosba o doplnění kódu

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

Veverka77
nováček
Příspěvky: 1
Registrován: leden 17
Pohlaví: Muž

VBA - prosba o doplnění kódu

Příspěvekod Veverka77 » 10 led 2017 16:04

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?


Kód: Vybrat vše

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

Dodatečně přidáno po 1 hodině 53 minutách 42 vteřinách:
Ještě dovysvětlím svůj problém:
Zdrojová tabulka se jmenuje Maso a list obsahuje:
__ A______ B______ C
1 Maso
2 ______ 1111______ 22
3______ 1133______ 44

Po vložení do sílové potřebuji, aby to vypadalo takto:

__ A______ B______ C
1 Maso 1111______ 22
2 Maso 1133______ 44



Reklama
  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Doplnění RAM
    od HiRes » 18 pro 2016 17:19 » v Rady s výběrem hardwaru a sestavením PC
    3
    115
    od Zagi
    21 pro 2016 08:15
  • Doplnění PC o RAM
    od Dannicek » 27 pro 2016 12:55 » v Rady s výběrem hardwaru a sestavením PC
    5
    85
    od Dannicek
    28 pro 2016 17:23
  • Doplnění inkoustu v tiskárně
    od lucaso84 » 11 pro 2016 11:27 » v Vše ostatní (hw)
    5
    250
    od Karel1943
    26 led 2017 12:22
  • Komponenty k doplnění GTX680
    od MatesBossy » 15 lis 2016 22:30 » v Rady s výběrem hardwaru a sestavením PC
    1
    79
    od socirel
    16 lis 2016 08:55
  • Kontrola sestavy + doplnění
    od Mikii84 » 16 pro 2016 21:03 » v Rady s výběrem hardwaru a sestavením PC
    1
    73
    od vuLva
    16 pro 2016 21:09

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: CommonCrawl [Bot] a 1 host