Opdatering af hele regneark i andet projekt

Hvis du vil have såvel tekst som format med fra et ark til et andet, og endda have automatisk opdatering af det hele er der nok ikke andet at gøre end at lave et stykke kodearbejde. Der sakl sandsynligvis laves kode i alle de projektmapper, du skal opdatere, foruden den du opdaterer fra.

jkrons>Der er tale om 2 ark, der skal opdateres FRA og hvert af arkene skal opdateres TIL 15 projekter.
De 15 projekter har bynavne. Er det ikke en opgave for dig? :-)

Måske ;-)  men det kniber lige lidt med tiden til større opgaver pt.

Den gratis tid har jo en begrænsning for os alle :-) www.win-consult.com

Med disse hints, vil I så sige, at opgaven er så stor, at der skal betaling til? (Seriøst spørgsmål)

Nu arbejder jeg ikke for betaling (i hvert fald ikke her :-) og måske kan du være heldig at finde en anden, der har det på samme måde men ja, opgaven virker forholdsvis stor.

Der findes flere herinde, som har evnerne til at løfte opgaven, så mon ikke du finder en, som vil hjælpe dig i ekspertens ånd - gratis.

Hr er en skabelon at gøre det over. Den er ikke optimeret, men burde funke.
Ale projektmappene (bynavnene) skal være åbne samtidig med at makroen køres.
Makroen skal ligge i den projekmappe, hvor de to ark der skal overføres,ligger.


Option Explicit
Option Base 1

Sub TransferSheets1()
Dim TemplateBook As Workbook
Dim templatesheet1 As Worksheet
Dim templatesheet2 As Worksheet
Dim shName1 As String, shName2 As String
Dim AllBooks
Dim x As Long
Set TemplateBook = ThisWorkbook
'Udfyld med de rigtige arknavne fra skabelonen
Set templatesheet1 = TemplateBook.Sheets("Temp1")
Set templatesheet2 = TemplateBook.Sheets("Temp2")
'Indsæt alle navnene på de projektmapper der skal udfyldes
AllBooks = Array("herning.xls", "randers.xls", "nordborg.xls")
'Indsæt navnene på de ark der skal have nyt indhold
shName1 = "Ark1"
shName2 = "Ark2"

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For x = LBound(AllBooks) To UBound(AllBooks)
    Workbooks(AllBooks(x)).Activate
    templatesheet1.Cells.Copy
    Application.Goto Sheets(shName1).Range("a1")
    Sheets(shName1).Paste
    Application.CutCopyMode = False
    templatesheet2.Cells.Copy
    Application.Goto Sheets(shName2).Range("a1")
    Sheets(shName2).Paste
    Application.CutCopyMode = False
    Workbooks(AllBooks(x)).Save
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

her er løkken optimeret lidt

For x = LBound(AllBooks) To UBound(AllBooks)
    templatesheet1.Cells.Copy Destination:=Workbooks(AllBooks(x)).Sheets(shName1).[a1]
    templatesheet2.Cells.Copy Destination:=Workbooks(AllBooks(x)).Sheets(shName2).[a1]
    Workbooks(AllBooks(x)).Save
Next

bak> Tak! Lige et dumt spørgsmål: Jeg skal "bare" ligge den ind som en makro og ændre de to ark-navne og tilføje de nye byer? Hvad sker der, når jeg efter 1. gangs opdatering og de gamle versioner af de to ark skal overskrives?

Forstår måske ikke lige spørgsmålet. De to ark skal findes i forvejen i hver af dine by-projekmapper. Når du kører makroen bliver de overskrevet med de nye data og formater fra dine skabelon-ark og gemt.

Giv en mail-adresse så sender jeg et eksempel

henrik@southfarm.dk

sendt

bak> Det virker fint, men jeg vil gerne have at arkene beholder sine navne fra den oprindelige projektmappe. Samtidig vil jeg gerne have at arkene der kopieres TIL lukker efter der er gemt. Hvad skal tilføjes og hvor?

Makroen ændrer ikke navnene og indsætter heller ikke nye ark. Arkene og navnene skal passe på forhånd, men her er koden ændret lidt så den kører på de samme navn.


Sub TransferSheets1()
Dim TemplateBook As Workbook
Dim templatesheet1 As Worksheet
Dim templatesheet2 As Worksheet
Dim shName1 As String, shName2 As String
Dim AllBooks
Dim x As Long
On Error GoTo HandleErr
Set TemplateBook = ThisWorkbook
'Udfyld med de rigtige arknavne fra skabelonen
Set templatesheet1 = TemplateBook.Sheets("Temp1")
Set templatesheet2 = TemplateBook.Sheets("Temp2")
'Indsæt alle navnene på de projektmapper der skal udfyldes
AllBooks = Array("herning.xls", "randers.xls", "nordborg.xls")
'Indsæt navnene på de ark der skal have nyt indhold
shName1 = templatesheet1.name
shName2 = templatesheet2.name
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For x = LBound(AllBooks) To UBound(AllBooks)
    templatesheet1.Cells.Copy Destination:=Workbooks(AllBooks(x)).Sheets(shName1).[a1]
    templatesheet2.Cells.Copy Destination:=Workbooks(AllBooks(x)).Sheets(shName2).[a1]
    Workbooks(AllBooks(x)).Close savechanges:=True
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
ExitHere:
    Exit Sub
' Automatic error handler last updated at 02-20-2004 08:52:50
HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Module2.TransferSheets1"    'ErrorHandler:$$N=Module2.TransferSheets1
    End Select
' End Error handling block.
End Sub

Bak> Tak, jeg er på vej hjem og kommer først på arbejde onsdag. God weekend :-)

Bak> Nu har jeg fået afprøvet det og det virker! Vil du lige sende et Svar, så du kan få dine point!

Ok, her er et svar
Bedre sent end aldrig :-)