Makro - přidání místo přepsání Vyřešeno

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

Moderátor: Mods_senior

pesekroman
nováček
Příspěvky: 1
Registrován: listopad 18
Pohlaví: Muž

Makro - přidání místo přepsání

Příspěvekod pesekroman » 26 lis 2018 10:46

Zdravím,

je tu spousty rad a něco mi pomůže, ale jsem naprostý amatér a řeším jeden problém.

Potřebuji aby mi tento script dokázal nejen zapsat ty hodnoty, ale přidat je pod poslední záznam. Teď pouze zapíše a přepíše.

Sub ZapisLidiDoDenniZaznam()
poc = 0
For i = 2 To 1000
If Cells(i, 11).Value <> "" Then
'cteni z
Měsíc = Cells(i, 1)
ID = Cells(i, 2)
Záloha = Cells(i, 5)
Datum = Cells(i, 6)
Způsob = Cells(i, 7)
Prémie = Cells(i, 8 )
Poznámka = Cells(i, 9)
'zapis do

Sheets("Denní záznam").Cells(2 + poc, 1) = Měsíc
Sheets("Denní záznam").Cells(2 + poc, 2) = ID
Sheets("Denní záznam").Cells(2 + poc, 7) = Záloha
Sheets("Denní záznam").Cells(2 + poc, 8 ) = Datum
Sheets("Denní záznam").Cells(2 + poc, 9) = Způsob
Sheets("Denní záznam").Cells(2 + poc, 10) = Prémie
Sheets("Denní záznam").Cells(2 + poc, 11) = Poznámka
poc = poc + 1
End If
Next
Sheets("Denní záznam").Select
End Sub

Předem moc díky za pomoc



Reklama
Uživatelský avatar
elninoslov
Level 2
Level 2
Příspěvky: 167
Registrován: červen 13
Pohlaví: Muž

Re: Makro - přidání místo přepsání  Vyřešeno

Příspěvekod elninoslov » 26 lis 2018 12:47

No, bez prílohy, čisto z brucha ...
Smerodajný stĺpec pre určenie počtu vyplnených riadkov som dal v oboch listoch 11, teda K:K.

Kód: Vybrat vše

Sub ZapisLidiDoDenniZaznam()
Dim Radku As Long, i As Long, Pocet As Long, D(), DZ1(), DZ2()
   
    With ThisWorkbook
        With .ActiveSheet
            Radku = .Cells(Rows.Count, 11).End(xlUp).Row - 1
            If Radku = 0 Then Exit Sub
            ReDim D(1 To Radku, 1 To 11)
            D = .Cells(2, 1).Resize(Radku, 11).Value
       
            For i = 1 To Radku
                If D(i, 11) <> "" Then
                    'cteni z
                    Pocet = Pocet + 1
                    ReDim Preserve DZ1(1 To 2, 1 To Pocet)
                    ReDim Preserve DZ2(1 To 5, 1 To Pocet)
                    DZ1(1, Pocet) = D(i, 1): DZ1(2, Pocet) = D(i, 2)
                    DZ2(1, Pocet) = D(i, 7): DZ2(2, Pocet) = D(i, 8): DZ2(3, Pocet) = D(i, 9)
                    DZ2(4, Pocet) = D(i, 10): DZ2(5, Pocet) = D(i, 11)
                End If
            Next i
        End With
       
        If Pocet > 0 Then
            'zapis do
            With .Worksheets("Denní záznam")
                Radku = .Cells(Rows.Count, 11).End(xlUp).Row + 1
                .Cells(Radku, 1).Resize(Pocet, 2).Value = WorksheetFunction.Transpose(DZ1)
                .Cells(Radku, 7).Resize(Pocet, 5).Value = WorksheetFunction.Transpose(DZ2)
                .Activate
            End With
        End If
    End With
End Sub


EDIT 26.11.2018 18:45 :
Malá oprava kódu, zabudol som transponovať pole DZ1. Opravená aj ukážka aj príloha. Namiesto

Kód: Vybrat vše

.Cells(Radku, 1).Resize(Pocet, 2).Value = DZ1

má byť samozrejme

Kód: Vybrat vše

.Cells(Radku, 1).Resize(Pocet, 2).Value = WorksheetFunction.Transpose(DZ1)
Nemáte oprávnění prohlížet přiložené soubory.


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Přepsání dat před prodejem HDD
    od buripe » 30 srp 2018 09:08 » v Vše ostatní (hw)
    7
    497
    od buripe
    31 srp 2018 20:46
  • Nová karta chráněna proti přepsání
    od Moony » 17 led 2018 20:29 » v Vše ostatní (hw)
    5
    585
    od Moony
    22 led 2018 20:46
  • Přidání ram
    od xTomikesx » 16 čer 2018 20:06 » v Problémy s hardwarem
    6
    517
    od xTomikesx
    16 čer 2018 20:37
  • Přidání serveru do domény
    od Amax123 » 11 dub 2018 19:05 » v Vše ostatní (sw)
    9
    486
    od zeus
    11 dub 2018 21:36
  • přidání odkazu do formuláře
    od setuB » 17 led 2018 06:55 » v Kancelářské balíky
    1
    343
    od xlnc
    17 led 2018 10:38

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

Kdo je online

Uživatelé prohlížející si toto fórum: CommonCrawl [Bot], Custo [Bot] a 3 hosti