sheet kopiëren naar andere werkmap, met unieke sheet naam uit cel.

[MennoL]

Hoi allemaal,

Ben al een tijdje op zoek naar een bepaalde VBA code, maar vindt overal stukjes die helaas niet leiden naar wat ik zoek.
Er zijn 20 excel bestanden verdeeld over 20 verschillende locaties door het land. Deze dienen 1x in de week een bepaalde sheet "heads up" genaamd, te kopiëren naar een ander excel bestand op een netwerkschijf (verzamelsheet.xlsx). Dit gebeurd nu via een VBA code waarbij de sheet gemaild wordt, maar de ontvanger heeft nu iedere week 20 mailtjes met excel bestanden en moet dan gaan zelf gaan puzzelen. Dit moet vast veel makkelijker kunnen.

De link waar het naartoe geschreven moet worden staat staat in een bepaalde cel (bijvoorbeeld C15, net als de naam dat de sheet moet gaan krijgen (D15). Iedere week moet er een nieuw bestand worden gemaakt (weeknummer staat in cel E15), dus als het bestand nog niet bestaat, dan moet deze gemaakt worden en de sheet toegevoegd worden. Bestaat het bestand al wel, dan moet alleen de sheet toegevoegd worden (met dus de unieke naam uit cel D15). Als iedereen op bijvoorbeeld zaterdag de macro heeft uitgevoerd, dan moet er maandag dus 1 bestand zijn genaamd "9.xlsx" (als het week 9 is) beschikbaar zijn. Week later moet er een bestand genaamd 10.xlsx zijn etc. aan het einde van het jaar zijn er dus 52 bestanden in die map. Al deze bestanden hebben dan 20 werkbladen met ieder de unieke naam uit cel D15.

De code moet wel een melding geven als het bestand al geopend is door een andere gebruiker, zodat deze het later nogmaals kan proberen. Na het openen en kopiëren van de sheet, moet het verzamelbestand weer automatisch sluiten, zodat de volgende er weer mee aan de slag kan.

Is dit mogelijk en heeft iemand een idee hoe? Zie veel mooie codes voorbij komen, maar kan bovenstaande VBA helaas niet terug vinden.

 

[VenA]

Moet dit geheel voor je gemaakt worden of heb je een voorbeeld met hoe het hele proces nu loopt? Kan je niet beter aan een bv Access database denken?

 

[MennoL]

Hoi VenA,

Ik heb voor zover onderstaande code:

Public Sub CopySheetFromOtherWorkbook()
Application.DisplayAlerts = False
Dim vFilename
Dim SourceBook As Workbook
Dim TargetBook As Workbook
Dim sSheet1 As String
Dim sSheet2 As String

'geef aan wat het originele werkboek is
'(het werkboek waarin we gaan werken)
Set TargetBook = Application.ActiveWorkbook

'kijk of het standaard werkboek bestaat
If FileExists(Sheets("Heads Up").Range("F14").Value) Then
'het standaardbestand bestaat dus open die
vFilename = Sheets("Heads Up").Range("F14").Value
Else
'het standaardbestand bestaat niet, dus vraag de gebruiker
'om een bestand te selecteren
vFilename = Application.GetOpenFilename("Excel bestanden (*.xlsx), *.xlsx")
End If

'kijk of er een bestand is geselecteerd
If vFilename <> False Then
'een bestand is geselecteerd dus open die
Set SourceBook = Workbooks.Open(vFilename)

'kopieer sheet "A" van het geopende werkboek
SourceBook.Sheets("Heads Up").Select
'plak de gekopieerde sheet achter de eerste sheet v/h originele werkboek
TargetBook.Sheets("Heads Up").Copy After:=SourceBook.Sheets(1)

'geef melding dat de sheet is gekopieerd
sSheet1 = "Heads Up"
sSheet2 = TargetBook.Sheets(1).Name
MsgBox "Sheet " & sSheet1 & " is gekopieerd in werkboek " & TargetBook.Name & " achter sheet " & sSheet2, _
vbInformation + vbOKOnly, _
"Sheet gekopieerd!"

ActiveSheet.Name = ActiveSheet.Range("C17")
ActiveSheet.Shapes("Button 1").Delete

End If

'Ervoor zorgen dat alle formules worden vervangen door getallen
Application.Run ("All_Cells_In_Active_WorkSheet_1")
Application.Run ("All_Cells_In_Active_WorkSheet_2")

Application.DisplayAlerts = True
End Sub

Private Function FileExists(fname) As Boolean
'Geeft TRUE terug als een bestand bestaat
Dim x As String

x = Dir(fname)
FileExists = IIf(x <> "", True, False)

End Function
Sub All_Cells_In_Active_WorkSheet_1()
ActiveSheet.Unprotect
With ActiveSheet.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
ActiveSheet.Protect
End Sub
Sub All_Cells_In_Active_WorkSheet_2()
ActiveSheet.Unprotect
With ActiveSheet.UsedRange
.Value = .Value
End With
ActiveSheet.Protect
End Sub

Alleen nu moet hij nog het geopende bestand weer direct afsluiten en een melding geven als deze al geopend is door iemand anders. Het hoofdbestand waar de macro in zit, moet gewoon geopend blijven.