< návrat zpět

MS Excel

Téma: Kopírování formátu buněk VBA rss

Zaslal/a fallecimiento 7.2.2015 19:32

Ahoj lidi, potřeboval bych poradit s jednou maličkostí....mám excelovskou tabulku do které se mi pomocí vba při stisknutí tlačítka přidávají řádky (20)....potřebuju aby se mi do nově přidané řádky "zkopíroval" formát který je již použit v řádce nad první vloženou...pro přidání řádků používám tento kód...jak to upravit?

Sub VW()
Dim ws As Worksheet, wsD As Worksheet 'zkratky pro jednotlive listy
Dim iRow1 As Long
Dim dtDatum As Date

Set ws = Worksheets("vw")
Set wsD = Worksheets("-D")

dtDatum = CDate(Fix(Now()))

'posledni moznost si to rozmyslet
If vbNo = MsgBox("Chystáš se přidat položky do databáze projektu " & vbCrLf _
& "Opravdu to chceš udělat?", vbYesNo) Then Exit Sub

'jestli je na databazi nasazen filtr, tak ho oddelej
If wsD.FilterMode Then wsD.ShowAllData

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A2") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B2") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C2") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A3") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B3") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C3") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A4") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B4") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C4") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A5") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B5") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C5") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A6") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B6") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C6") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A7") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B7") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C7") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A8") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B8") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C8") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A9") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B9") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C9") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A10") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B10") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C10") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A11") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B11") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C11") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A12") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B12") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C12") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A13") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B13") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C13") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A14") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B14") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C14") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A15") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B15") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C15") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A16") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B16") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C16") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A17") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B17") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C17") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A18") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B18") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C18") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A19") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B19") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C19") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A20") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B20") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C20") 'Něco

'zjisti cislo posledniho radku v databazi
iRow1 = wsD.Range("A65000").End(xlUp).Row
iRow1 = iRow1 + 1 'budeme pripisovat na dalsi radek

'pripis novy radek do databaze
wsD.Cells(iRow1, "A") = ws.Range("A21") 'Projekt
wsD.Cells(iRow1, "B") = ws.Range("B21") 'Level
wsD.Cells(iRow1, "C") = ws.Range("C21") 'Něco


wsD.Activate

End Sub

stop Uzamčeno - nelze přidávat nové příspěvky.
kp57(7.2.2015 20:57)#023521
avatar
např:Sub VW()
Dim ws As Worksheet, wsD As Worksheet 'zkratky pro jednotlive listy
Dim iRow1 As Long, xRadku As Byte
Dim dtDatum As Date
Set ws = Worksheets("vw")
Set wsD = Worksheets("-D")
dtDatum = Date
'posledni moznost si to rozmyslet
If vbNo = MsgBox("Chystáš se pøidat položky do databáze projektu " & vbCrLf _
& "Opravdu to chceš udìlat?", vbYesNo) Then Exit Sub
'jestli je na databazi nasazen filtr, tak ho oddelej
If wsD.FilterMode Then wsD.ShowAllData
'zjisti cislo posledniho radku v databazi + 1
iRow1 = wsD.Range("A65000").End(xlUp).Row + 1
'pocet kopirovanych radku
xRadku = 20
'kopiruj xRadky do databaze
ws.Range("A2:C" & xRadku + 1).Copy wsD.Range("A" & iRow1)
'kopiruj format
wsD.Range("A" & iRow1 - 1 & ":C" & iRow1 - 1).Copy
wsD.Range("A" & iRow1 & ":C" & iRow1 + xRadku - 1).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False

wsD.Activate
wsD.Range("A" & iRow1).Select
Set wsD = Nothing
Set ws = Nothing
End Sub
citovat
fallecimiento(7.2.2015 21:31)#023523
avatar
kp57 to je přesně ono co jsem potřeboval. Jen jsem to ještě rozšířil na vvíc sloupců....jsi dobrej...díky moccitovat

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