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ž
Stav:
Offline

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.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

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)
Přílohy
Zápis lidí do Denní záznam.xlsm
(21.39 KiB) Staženo 21 x


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Přidání RAM Příloha(y)
    od Airen » 19 čer 2023 15:56 » v Rady s výběrem hw a sestavením PC
    11
    1494
    od Airen Zobrazit poslední příspěvek
    01 srp 2023 09:26
  • Přidání RAMek
    od Qinter » 12 led 2024 18:34 » v Rady s výběrem hw a sestavením PC
    6
    856
    od Zivan Zobrazit poslední příspěvek
    17 led 2024 08:57
  • Po přidání RAM počítač pípá
    od OutS1d3r » 21 úno 2024 19:01 » v Problémy s hardwarem
    2
    526
    od petr22 Zobrazit poslední příspěvek
    21 úno 2024 19:10
  • Datový model - aktualizace po přidání dalšího sloupce do Access
    od MK_Vs » 27 črc 2023 12:05 » v Kancelářské balíky
    0
    1626
    od MK_Vs Zobrazit poslední příspěvek
    27 črc 2023 12:05
  • Misto zvuku 5.1 jen 2.0
    od kuře » 19 říj 2023 14:32 » v Windows 11, 10, 8...
    7
    1617
    od richchie Zobrazit poslední příspěvek
    24 říj 2023 09:25

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

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 8 hostů