nefunkční přepis dat Vyřešeno

[m.niki]

Nevíte někdo proč mi nefunguje tento kód? data se mi přepisujou do původního sešitu a przní ho, potřebuji aby se data přepsala do sešitu evidence_faktur.xls, ten se sice otevře, ale už se do něj nic nevpíše

Kód: Vybrat vše

Sub tlačítko1_Klepnutí()

ID1 = Cells(1, 1)
ID2 = Cells(1, 2)
ID3 = Cells(1, 3)

Application.Workbooks.Open ThisWorkbook.Path & "\evidence_faktur.xls"
Windows("evidence_faktur.xls").Activate

Cells(4, 1) = ID1
Cells(4, 2) = ID2
Cells(4, 3) = ID3

End Sub


děkuji moc za rady

[Reklama]

[navstevnik]

Pokud je procedura Sub tlačítko1_Klepnutí() ukoncena End Sub a je umistena ve standardnim modulu, je volana tlacitkem z Panely nastroju>Formulare (a prirazena tato procedura), vlozi spravne hodnoty do noveho sesitu. Kdyz, tak priloz oba sesity s nefunkcni procedurou a obsahujici jen ta nejnutnejsi data a proceduru a tlacitko.

Vhodnejsi je pouzit ovladaci prvek z Panely nastroju>Ovladaci prvky, vlozit tlacitko CommandButton1 na list a v modulu prislusneho listu pouzit udalostni proceduru (ukazkove v nejjednodussim tvaru):

Kód: Vybrat vše

Private Sub CommandButton1_Click()

  Application.Workbooks.Open ThisWorkbook.Path & "\evidence_faktur.xls"

  With Workbooks("evidence_faktur.xls").Worksheets("list1")
    .Cells(4, 1) = Cells(1, 1)
    .Cells(4, 2) = Cells(1, 2)
    .Cells(4, 3) = Cells(1, 3)
  End With
End Sub

[m.niki]

děkuji, s tvým kódem to funguje jak má. Ještě bych k tomu měl jeden dotat: Když bych chtěl, aby zápis proběhl na první volný řádek jak to mám udělat? zkoušel jsem kód změnit takto:

Kód: Vybrat vše

Private Sub zapis_dat_Click()

  Application.Workbooks.Open ThisWorkbook.Path & "\evidence_faktur.xls"

  With Workbooks("evidence_faktur.xls").Worksheets("list1")
  Dim rd As Single
  rd = 3
  Do While Cells(rd, 1) <> ""
  rd = rd + 1
  Loop 
    .Cells(rd, 1) = Cells(1, 9)
    .Cells(rd, 2) = Cells(7, 1)
    .Cells(rd, 3) = Cells(30, 13)
  End With

End Sub


ale někde se stala chyba a zápis probíhá pořád na ten samý řádek, nechtěl jsem zde dát hned žádost na napsání celého makra, protože se to snažím pochopit, ale nějak do toho nemůžu proniknout :(

[navstevnik]

V sesitu evidence_faktur.xls je predpokladan hlavickovy radek 1:1.
Nize uvedena procedura (v editoru VBA vloz do modulu prislusneho listu) otevre sesit evidence_faktur.xls, a na list List1 (v procedure zmen dle potreby) ulozi na prvni volny radek pocinaje sloupcem A:A data z bunek I1, A7, M30 (uprav dle potreby) a sesit zavre.

Kód: Vybrat vše

Option Explicit

Private Sub CommandButton1_Click()
  Dim TWbk As Workbook, TWsht As Worksheet, TCll As Range
  Dim Wsht As Worksheet
  Dim LstR As Long
  ' zdrojovy list
  Set Wsht = Me
  Application.ScreenUpdating = False
  ' otevreni ciloveho sesitu
  On Error Resume Next
  Application.Workbooks.Open ThisWorkbook.Path & "\evidence_faktur.xls"
  If Err.Number <> 0 Then
    MsgBox "Cilovy sesit nebyl nalezen"
    GoTo Err1
  End If
  Set TWbk = ActiveWorkbook
  ' a cilovy list
  Set TWsht = TWbk.Worksheets("list1")
  If Err.Number <> 0 Then
    MsgBox "Cilovy list nebyl nalezen"
    GoTo Err2
  End If
  On Error GoTo 0
  ' nalezeni prvni volne bunky (radku) ve sloupci A:A na cilovem listu
  With TWsht
    Set TCll = .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row).Offset(1, 0)
  End With
  ' prenest data na cilovy list
  With TCll
    .Value = Wsht.Range("i1")
    .Offset(0, 1).Value = Wsht.Range("a7")
    .Offset(0, 2).Value = Wsht.Range("m30")
  End With
  ' odstranit objektove promenne
  Set TCll = Nothing
  Set TWsht = Nothing
Err2:
  TWbk.Close True  ' zavrit cilovy sesit s ulozenim
  Set TWbk = Nothing
Err1:
  Application.ScreenUpdating = True
End Sub

Otestuj, snad vyhovi zameru.

[m.niki]

ozkoušel jsem to, ale na řádku

Kód: Vybrat vše

   Set TCll = .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row).Offset(1, 0)

to hlásí chybu, kdyžtak se prodím zkus podívat - soubory jsou v příloze, moc dík

[navstevnik]

V procedure si nahrad radek:
...
' nalezeni prvni volne bunky (radku) ve sloupci A:A na cilovem listu
With TWsht
Set TCll = .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row).Offset(1, 0)
End With
...

timto radkem:

Kód: Vybrat vše

Set TCll = .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Offset(1, 0)

Psal jsem to pod nizsi verzi Excelu. Bohuzel se vloudila chybicka, ktera se projevila az pri kombinaci souboru pokus_zapis.xlsm (2007) a evidence_faktur.xls (2000-3).
Je to chybejici tecka pred Rows.Count, coz odkazovalo na list sesitu pokus_zapis.xlsm, zatimco mel byt odkaz na list v evidence_faktur.xls. Oba soubory v Ex 2000-3 mely shodny pocet radku na listu, zatimco zde maji rozdilny pocet radku, pricemz v pripade, ze by byl pokus_zapis.xls (2000-3) a evidence_faktur.xlsx (2007) nebo oba soubory v Ex 2007, by se chyba take neprojevila, jen by to nebylo ciste reseni.

[m.niki]

navstevniku děkuji za tvuj čas a ochotu, tečku jsem doplnil a už vesele zapisuju :)