MS Excel

Téma: Neposunuje se mi řádek a to mě zlobí...

Zaslal/a Johan-Kraczmar 11.8.2015 11:37

Ahoj všichni, potřeboval jsem rozšířit databázi o další pole, avšak po úpravě kódu se mi nechce buňka F posunovat dolu..... Co mám špatně??

Sub saveandsend()

Dim r As Long, Z As Range
Dim posl As Integer, N As String

If MsgBox("JSOU ZADANÉ ÚDAJE V POŘÁDKU ?", vbYesNo, "Odeslání do databáze") = vbYes Then ' okno z upozorněním o vyčištění formuláře

Set Z = Sheets("Databáze").Range("A2:F2") 'První záznam v DB
With Z
On Error Resume Next 'První volný řádek
r = .Resize(Sheets("Databáze").Range("A:A").Rows.Count - .Row + 1).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row - .Row + 1
On Error GoTo 0

' 1. Poslední záznam jako poslední v DB -------------------------------------
'Z.Offset(r, 0).Value = Sheets("Formulář").Range("B4:F4").Value

' -----------------------------------------------------------------

' 2. Poslední záznam na jako první v DB -------------------------------------
.Resize(r + 1 - IIf(r > 0, 1, 0), .Columns.Count).Offset(1, 0).Value = .Resize(r + 1 - IIf(r > 0, 1, 0), .Columns.Count).Value 'Posun o řádek dolů
.Value = Sheets("Datový list").Range("A26:F26").Value 'Poslední zápis na první řádek DB

End With

With ThisWorkbook 'Pro tento sešit
.Worksheets("Protokol").Copy after:=.Worksheets("Databáze") 'Kopíruj list Protokol
With .Worksheets("Datový list")
N = .Range("A26") & " " & .Range("C26") 'Název pro nový list
End With
With .Worksheets(.Worksheets("Databáze").Index + 1) 'Pro novou kopii
.Name = N 'Nastav název
.Buttons("btnOdeslatUlozit").Delete 'vymaž zkopírované tlačítko
.Range("B2:M44").Validation.Delete 'vymaže seznamy
End With
.Save
End With

Worksheets("Protokol").Activate
Range("D28,D29,D30,K5,B5,B8,C8,D8,G8,L8,B10,F11,F15,H15,L15,F16,H16,L16,F17,H17,L17,F18,H18,L18,F21,H21,L21,F22,H22,L22,F25,H25,L25,F28,H28,L28,F29,H29,L29,F30,H30,L30,B33,F40,H40,L40").Select ' vybere zadanou oblast buněk
Selection.ClearContents ' vymaže data
ThisWorkbook.Save ' uloží

End If
End Sub

Zaslat odpověď >

elninoslov(11.8.2015 13:06)#026214

Skúste:
Sub saveandsend()
Dim r As Long, N As String
If MsgBox("JSOU ZADANÉ ÚDAJE V POŘÁDKU ?", vbYesNo, "Odeslání do databáze") <> vbYes Then End ' okno z upozorněním o vyčištění formuláře
With ThisWorkbook 'Pro tento sešit
With .Worksheets("Databáze").Range("A2:F2") 'První záznam v DB
On Error Resume Next 'První volný řádek
r = .Resize(Rows.Count - .Row + 1).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row - .Row + 1
On Error GoTo 0
.Resize(r + 1 - IIf(r > 0, 1, 0), .Columns.Count).Offset(1, 0).Value = .Resize(r + 1 - IIf(r > 0, 1, 0), .Columns.Count).Value 'Posun o řádek dolů
.Value = ThisWorkbook.Worksheets("Datový list").Range("A26:F26").Value 'Poslední zápis na první řádek DB
End With
.Worksheets("Protokol").Copy after:=.Worksheets("Databáze") 'Kopíruj list Protokol
With .Worksheets("Datový list")
N = .Cells(26, 1) & " " & .Cells(26, 3) 'Název pro nový list
End With
With .Worksheets(.Worksheets("Databáze").Index + 1) 'Pro novou kopii
.Name = N 'Nastav název
.Buttons("btnOdeslatUlozit").Delete 'vymaž zkopírované tlačítko
.Range("B2:M44").Validation.Delete 'vymaže seznamy
End With
With .Worksheets("Protokol")
.Activate
.Range("D28,D29,D30,K5,B5,B8,C8,D8,G8,L8,B10,F11,F15,H15,L15,F16,H16,L16,F17,H17,L17,F18,H18,L18,F21,H21,L21,F22,H22,L22,F25,H25,L25,F28,H28,L28,F29,H29,L29,F30,H30,L30,B33,F40,H40,L40").ClearContents ' vymaže zadanou oblast buněk
End With
.Save ' uloží
End With
End Sub
testované iba po riadok .Worksheets("Protokol").Copy ...citovat

Johan-Kraczmar(11.8.2015 13:38)#026215

Bohužel to samé, možná bych Ti mohl poslat celý sheet ať si to můžeš vyzkoušet?citovat

elninoslov(11.8.2015 13:57)#026216

No veď mne to práve funguje korektne. Pošlite mi teda zošit na mail čo mám uvedený v profile.citovat

Téma: Neposunuje se mi řádek a to mě zlobí...

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje