Cellen kopieren van verschillende tabbladen naar 1 tabblad

Status
Niet open voor verdere reacties.
Harry

het is inderdaad een moeilijke opdracht :)

Kijk even in bijlage, daar werkt alles perfect, rijen verborgen, niet verborgen, layout enz ....
de tabbladen zijn verschillend, en ik kan tabblad voor tabblad apart kopieren hetgeen ik ook zou wil houden.

tomBekijk bijlage TestStockbeheer.xlsm

nu wil ik in feite hetzelfde als in die map, enkel de te kopieren data moet naar een andere werkmap"stockbeheer 2017" tabblad stockbeheer
 
Harry,

Nog een rariteit, ik ben bezig met het kopieren van de data, hetgeen opzicht perfect werkt, echter als ik op tabblad stockbeheer aan rij 134 kom, wordt de data niet meer eronder geplakt, maar overschrijft hij de andere data ?

Heb het bestand meegestuurd

Bekijk bijlage TestStockbeheer.xlsm

Tom
 
Tom,

In #35 staat hoe het wel moet.
 
Je moet ook niet alle codes door elkaar halen.
Die code is naar een ander bestand, maar daar staan wel gegevens die ook goed zijn voor hetzelfde werkboek naar een ander blad.
 
harry,

Sorry Sorry Sorry

Kheb het gevonden, er zaten 3 fouten in tabbladen, heb die eruit gehaald en werkt PERFECT !!!

1 vraag, gans de boel wordt nu ineens gekopieerd, ik ga nu testen wat er gebeurt als er een NIEUW tabblad wordt toegevoegd

Ik hou je op de hoogte

tom
 
Harry,

net getest, als ik een nieuw tabblad toevoeg, en een order input, dan zeg macro uitvoeren, dan kopiert hij terug alle bladen :)
das niet de bedoeling, ik opper nog steeds dat ik blad voor blad kan toevoegen naar stockbeheer2017

tom
 
Dan haal je de lus eruit en plaats er activesheet voor terug.

Je bent een beetje warrig; eerst alle bladen met 9 karakters en nu weer blad voor blad?
 
Sorry voor soms het warrige harry, ben dan ook geen expert he :) (en kan moeilijk juist schrijven hetgeen ik wil)

zal eens proberen of me dat lukt, een lus uithalen en activesheet inplaatsen :)

doe mijn best

we zijn al wel een eind op de goede weg, ben blij hiervoor

tom
 
Moet het nu weer één blad worden, en als jij dat wilt een volgend blad, en niet alle bladen gelijk?
Als je daar uit bent, en het wil niet lukken, dan staat volgens mij het antwoord al in #20 op die foute 124 na (wat 'rows.count' moest zijn).

Maar we blijven een beetje in een cirkeltje draaien zo.
 
neenee harry, geen cirkels meer draaien :p:p:p:p

we zijn er bijna, alles is PERFECT .....
enkel ben ik nog steeds bezig met die lus eruit te krijgen, en activesheet te plaatsen

Nog even ter verduidelijking:
Alle tabbladen met 9 karakters uit werkmap Inkoopboek, kopieren bepaalde cellen, naar werkmap Stockbeheer2017 op tabblad stockbeheer
Maar de macro moet dit NIET ineens doen ! (ik doe dat via een knop per tabblad)

dit is omdat er dagelijks extra nieuwe tabbladen worden bijgemaakt omdat er steeds nieuwe inkooporders bijkomen, als dan de input in de nieuwe tabblad volledig is ingevuld, duw ik op de knop, en komt dan de bepaalde cellen automatisch in stockbeheer

tom
 
harry,

kan je me helpen aub, krijg het niet voor elkaar

je zei, haal de lus eruit en plaats activesheet

Kan je aanduiden waar dat dat gebeurt in de sub

Sub hsv()
Dim sh As Worksheet, c As Range
Application.ScreenUpdating = False
With GetObject(ThisWorkbook.Path & "\StockBeheer2017.xlsm")
.Windows(1).Activate
With .Sheets("stockbeheer")
For Each sh In ThisWorkbook.Sheets
If Len(sh.Name) = 9 Then
sh.Range("A22:U" & Application.Max(22, sh.Cells(125, 4).End(xlUp).Row)).Copy
Application.Goto .Cells(Application.Max(14, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2)
.Cells(Application.Max(14, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).PasteSpecial -4122
.Paste , True
.Cells(Application.Max(14, .Cells(Rows.Count, 23).End(xlUp).Offset(1).Row), 23).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - Application.Max(14, .Cells(Rows.Count, 23).End(xlUp).Row)) = sh.Cells(4, 19).Value
Application.CutCopyMode = 0
End If
Next sh
For Each cl In .Columns(2).SpecialCells(-4123)
If cl.Value = 0 Then
If c Is Nothing Then Set c = cl Else Set c = Union(c, cl)
End If
Next cl
If Not c Is Nothing Then c.EntireRow.Delete
End With
End With
End Sub

bedankt alvast

Tom
 
Graag gebruik maken van codetags zoals onderstaand.

Code: 
Sub hsv()
Dim sh As Worksheet, c As Range, rng As Range, cl As Range
Application.ScreenUpdating = False
Set sh = ActiveSheet
With GetObject(ThisWorkbook.Path & "\StockBeheer2017.xlsm")
.Windows(1).Activate
  With .Sheets("stockbeheer")
Set rng = .Cells(Application.Max(14, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 2)
        If Len(sh.Name) = 9 Then
                sh.Range("A22:U" & Application.Max(22, sh.Cells(125, 4).End(xlUp).Row)).Copy
                Application.Goto .Cells(Application.Max(14, .Cells(Rows.Count, 2).End(xlUp).Offset(1).Row), 2)
                .Cells(Application.Max(14, .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1).PasteSpecial -4122
                .Paste , True
                .Cells(Application.Max(14, .Cells(Rows.Count, 23).End(xlUp).Offset(1).Row), 23).Resize(.Cells(Rows.Count, 2).End(xlUp).Row - Application.Max(14, .Cells(Rows.Count, 23).End(xlUp).Row)) = sh.Cells(4, 19).Value
                Application.CutCopyMode = 0
        End If
     For Each cl In .Range(.Cells(rng.Row, 2), .Cells(Rows.Count, 2).End(xlUp))
      If cl.Value = 0 Then
         If c Is Nothing Then Set c = cl Else Set c = Union(c, cl)
      End If
     Next cl
    If Not c Is Nothing Then c.EntireRow.Delete
  End With
End With
End Sub
 
PERFECT !!!!

ben zo blij, we zijn er geraakt ! Nu kan ik even verder, we zijn al 80% van de af te leggen weg .... Er zijn al 5 werkmappen die PERFECT werken !

DANK Uw WEL HARRY

Ik kom nog wel terug met een laatste issue, maar eerst de rest nu afwerken !
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan