PC-HELP.CZ

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

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)

PC-HELP.CZ

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

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

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