Ahoj lidi, potřebuju poradit jak dostat nová data z tabulky na jednom listu do druhého listu v jednom sešitu ještě než dám uložit a zavřít. Do tabulky zapisuji denně jiná data, některá tam nechám jiná smažu a dodám jiná data(pokaždé jsou jiná, protože se liší obsahem některé z buněk)
41973_pokus.xlsx
Makrom ? Prázdne riadky nemusíte mazať, to sa urobí samé. Stačí iba uložiť súbor.
Sub Nove_data_do_DB()
Dim DA(), RA As Long, DB(), RB As Long, i As Long, rngDel As Range, ColB As New Collection, Vsetko As String, Polozka, PocetNovych As Long
With wsTabA
RA = .Cells(Rows.Count, 1).End(xlUp).Row - 2
If RA = 0 Then Exit Sub
ReDim DA(1 To RA, 1 To 5)
DA = .Cells(3, 1).Resize(RA, 5).Value2
End With
With wsTabB
RB = .Cells(Rows.Count, 1).End(xlUp).Row - 2
If RB > 0 Then
ReDim DB(1 To RB, 1 To 5)
DB = .Cells(3, 1).Resize(RB, 5).Value2
For i = 1 To RB
ColB.Add i, Join(Array(DB(i, 1), DB(i, 2), DB(i, 3), DB(i, 4), DB(i, 5)), "•")
Next i
End If
End With
Erase DB
On Error Resume Next
With wsTabA
For i = 1 To RA
Vsetko = Join(Array(DA(i, 1), DA(i, 2), DA(i, 3), DA(i, 4), DA(i, 5)), "•")
Select Case Len(Vsetko)
Case 4
If rngDel Is Nothing Then Set rngDel = .Cells(i + 2, 1).Resize(, 5) Else Set rngDel = Union(rngDel, .Cells(i + 2, 1).Resize(, 5))
Case Else
Polozka = ColB(Vsetko)
If Err.Number <> 0 Then
PocetNovych = PocetNovych + 1
ReDim Preserve DB(1 To 5, 1 To PocetNovych)
DB(1, PocetNovych) = DA(i, 1): DB(2, PocetNovych) = DA(i, 2): DB(3, PocetNovych) = DA(i, 3): DB(4, PocetNovych) = DA(i, 4): DB(5, PocetNovych) = DA(i, 5)
Err.Clear
End If
End Select
Next i
End With
On Error GoTo 0
If PocetNovych > 0 Then wsTabB.Cells(RB + 3, 1).Resize(PocetNovych, 5).Value2 = WorksheetFunction.Transpose(DB)
If Not rngDel Is Nothing Then rngDel.Delete Shift:=xlUp
End Sub
Skúšajte to výhradne na fyzickej kópii súboru !!!
Sub Nove_data_do_DB()
Dim DA(), RA As Long, DB(), RB As Long, i As Long, rngDel As Range, ColB As New Collection, Vsetko As String, Polozka, PocetNovych As Long
With wsTabA
RA = .Cells(Rows.Count, 1).End(xlUp).Row - 2
If RA = 0 Then Exit Sub
ReDim DA(1 To RA, 1 To 5)
DA = .Cells(3, 1).Resize(RA, 5).Value2
End With
With wsTabB
RB = .Cells(Rows.Count, 1).End(xlUp).Row - 2
If RB > 0 Then
ReDim DB(1 To RB, 1 To 5)
DB = .Cells(3, 1).Resize(RB, 5).Value2
For i = 1 To RB
ColB.Add i, Join(Array(DB(i, 1), DB(i, 2), DB(i, 3), DB(i, 4), DB(i, 5)), "•")
Next i
End If
End With
Erase DB
On Error Resume Next
With wsTabA
For i = 1 To RA
Vsetko = Join(Array(DA(i, 1), DA(i, 2), DA(i, 3), DA(i, 4), DA(i, 5)), "•")
Select Case Len(Vsetko)
Case 4
If rngDel Is Nothing Then Set rngDel = .Cells(i + 2, 1).Resize(, 5) Else Set rngDel = Union(rngDel, .Cells(i + 2, 1).Resize(, 5))
Case Else
Polozka = ColB(Vsetko)
If Err.Number <> 0 Then
PocetNovych = PocetNovych + 1
ReDim Preserve DB(1 To 5, 1 To PocetNovych)
DB(1, PocetNovych) = DA(i, 1): DB(2, PocetNovych) = DA(i, 2): DB(3, PocetNovych) = DA(i, 3): DB(4, PocetNovych) = DA(i, 4): DB(5, PocetNovych) = DA(i, 5)
Err.Clear
End If
End Select
Next i
End With
On Error GoTo 0
If PocetNovych > 0 Then wsTabB.Cells(RB + 3, 1).Resize(PocetNovych, 5).Value2 = WorksheetFunction.Transpose(DB)
If Not rngDel Is Nothing Then rngDel.Delete Shift:=xlUp
End Sub
Skúšajte to výhradne na fyzickej kópii súboru !!!
Příloha: 
41978_nove-polozky-do-db-pred-ulozenim-suboru.zip (22kB, staženo 23x)
citovat41978_nove-polozky-do-db-pred-ulozenim-suboru.zip (22kB, staženo 23x)
\n
RSS nejnovější články