Tabel deels kopieren

[oraluc]

Hoi,

Van een tabel met 7 kolommen wil ik:

• de 1e 3 kolommen als tabel kopiëren naar een andere werkmap
• alleen de waarden (dus niet de formules) moeten daar terechtkomen
• telkens bij het opslaan van dat bestand

Zover ben ik al gekomen:

Sheets("Werkblad").Range("tblOrg[[#All],[Artikelnummer]:[Locatie]]").Copy _
Destination:=Sheets("Locatie").Range("tblLocatie")

De kolomkoppen worden echter onder de bestaande kolomkoppen meegekopieerd.

Voorbeeldbestand is bijgevoegd.

Alvast bedankt.
Luc

 

[HSV]

In Thisworkbook.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 With Sheets("werkblad").ListObjects(1)
  Sheets("locatie").ListObjects(1).ListRows.Add.Range.Resize(.ListRows.Count) = .DataBodyRange.Resize(, 3).Value
 End With
End Sub

 

[oraluc]

Bedankt voor de reactie.

Kan ik die zo in een Module plakken?
Hij reageert dan niet op F8.
Luc

 

[HSV]

Nee, in Thisworkbook-module als je het bestand wilt opslaan draait de code automatisch.

 

[oraluc]

OK. Ziet er goed uit.
Mijn bedoeling was om de oude rijen (of de tabel) te overschrijven, ipv toe te voegen.
Wat moet ik dan wijzigen?

Luc

 

[HSV]

Een van de twee opties voor een standaard module.

Sub hsv()
Dim sv
sv = Sheets("werkblad").ListObjects(1).Range.Resize(, 3)
 With Sheets("locatie")
  .ListObjects(1).Delete
  .Cells(1).Resize(UBound(sv), 3) = sv
  .ListObjects.Add xlSrcRange, .Cells(1).CurrentRegion, , xlYes
 End With
End Sub

 

[oraluc]

Dat is volgens wens :thumb:
Is het niet mogelijk dit bij opslaan uit te voeren?
Luc

 

[HSV]

In de Thisworkbook-module dus.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sv
sv = Sheets("werkblad").ListObjects(1).Range.Resize(, 3)
 With Sheets("locatie")
  .ListObjects(1).Delete
  .Cells(1).Resize(UBound(sv), 3) = sv
  .ListObjects.Add xlSrcRange, .Cells(1).CurrentRegion, , xlYes
 End With

Een tweede methode.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sv
sv = Sheets("werkblad").ListObjects(1).DataBodyRange.Resize(, 3)
 With Sheets("locatie").ListObjects(1)
  .DataBodyRange.Delete
  .ListRows.Add.Range.Resize(UBound(sv)) = sv
End With
End Sub

 

[oraluc]

Moest nog een End Sub toevoegen in de 1e, maar dit werkt nu 100%. Waarvoor dank.

Er staan ook getallen in de originele tabel die opgemaakt zijn als tekst, waardoor ze links uitgelijnd worden. Dat zou ik in de nieuwe tabel ook willen hebben (staat nu op standaard).
Eigenlijk kan de hele tabel naar tekst.
Is dit makkelijk toe te voegen?
En is er een mogelijkheid om alleen een werkblad (in dit geval Locatie) te delen (alleen weergeven)?
Dat is uiteindelijk de bedoeling. Ik verwerk data en anderen kunnen dat raadplegen.
Luc

 

[HSV]

Eenmalig de kolommen op tekst zetten of links uitlijnen zou afdoende moeten zijn.

 

[oraluc]

Helaas werken beide niet als ik het op bron en doel aanpas.
Is geen halszaak maar ziet er verzorgder uit voor de gebruikers als alles (dus ook getallen) links uitgelijnd is.

Gr.
Luc

 

[HSV]

Beter?

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sv
sv = Sheets("werkblad").ListObjects(1).Range.Resize(, 3)
 With Sheets("locatie")
  if .listobjects.count then .ListObjects(1).Delete
  .Cells(1).Resize(UBound(sv), 3) = sv
  .ListObjects.Add xlSrcRange, .Cells(1).CurrentRegion, , xlYes
  .listobjects(1).databodyrange.numberformat= "@"
 End With
end with

Of nog een andere methode.

[COLOR=#333333]Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)[/COLOR]
With Sheets("locatie")
  If .ListObjects.Count Then .ListObjects(1).Delete
   Sheets("werkblad").ListObjects(1).Range.Resize(, 3).Copy
   .Cells(1).PasteSpecial 13
   .Cells(1).PasteSpecial 12
  .ListObjects.Add xlSrcRange, .Cells(1).CurrentRegion, , xlYes
  End With
application.cutcopymode = false
End Sub

 

[JEC.]

Klein typfoutje in de if regel, zal wel een error geven.

 

[HSV]

Ik heb het voor je aangepast.

 

[JEC.]

Was voor TS had een vermoeden dat het niet op zou vallen

 

[snb]

Of ?

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  sheets(sheets.count).delete
  sheets("werkblad").copy ,sheets(sheets.count)
  sheets(sheets.count).usedrange.offset(,3).clear
end with

 

[oraluc]

De oplossing van Harry werkt nu prima. Ziet er mooi uit.

De code van snb voegt er 2 werkbladen aan toe met alle kolommen.

Ik hou het bij de eerste. Bedankt beide.

Ik heb nog wel een vervolgvraag:

Als ik via een macro de gegevens uit het tabblad Locatie (als waarde) wil kopiëren naar een tabel in een ander document (bijgevoegd). Dat is door anderen te lezen.
Hoe kan dat het makkelijkst? Dit moet echter niet samen met de huidige macro. Ik wil zelf bepalen wanneer de gewijzigde gegevens 'openbaar' worden.

Groeten,
Luc

 

[HSV]

Op dezelfde voet dan maar.

Het rode gedeelte aanpassen.

Sub hsv()
Dim s0 As String
Application.ScreenUpdating = False
s0 = "helpmijvb doel.xlsx"
With GetObject("[COLOR=#ff0000]c:\users\Luc\documents[/COLOR]\" & s0).Sheets("nmg")
  If .ListObjects.Count Then .ListObjects(1).Delete
   ThisWorkbook.Sheets("locatie").ListObjects(1).Range.Resize(, 3).Copy
     .Cells(1).PasteSpecial 13
     .Cells(1).PasteSpecial 12
     .ListObjects.Add xlSrcRange, .Cells(1).CurrentRegion, , xlYes
     Windows(s0).Visible = True
     .Parent.Close -1
End With
Application.CutCopyMode = False
End Sub

 

[oraluc]

Sorry voor de onregelmatige reactietijd, maar ik werk ook buiten de deur en kan niet altijd meteen antwoorden.

Deze werkt, maar....

Kan de originele opmaak van de doeltabel behouden blijven en de tabelnaam tblNMG worden/blijven en de cursor daar op A2 komen (iig niet de hele tabel geselecteerd)?
Ik ga dit toepassen op bestanden voor verschillende depots die ieder hun eigen kleurstelling en tabelnaam hebben.

Bedankt.

 

[HSV]

Sub hsv()
Dim s0 As String
Application.ScreenUpdating = False
s0 = "helpmijvb doel.xlsx"
With GetObject("c:\users\Luc\documents\" & s0).Sheets("nmg")
  If .ListObjects.Count Then .ListObjects(1).Delete
   ThisWorkbook.Sheets("locatie").ListObjects(1).Range.Resize(, 3).Copy .Cells(1)
     .ListObjects(1).DataBodyRange = .ListObjects(1).DataBodyRange.Value
     Windows(s0).Visible = True
     .Parent.Close -1
End With
End Sub