06. juli 2004 - 14:22Der er
9 kommentarer og 1 løsning
Makro til overførsel af celler til andet ark
Jeg har brug for en makro der kopier A1:BF13 med de formater der er i regnearket fra et regneark til et andet.
Der skal kopieres fra i alt 18 filer over i et ark, sådan at A1:BF13 fra de 18 filer kommer til at stå under hinanden, så 2. "felt" står i A15:BF26 - nr. 3 fra A28:BF39 osv.
Jeg har nedenstående makro, der overføre 2 ark til i alt 15 andre filer:
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("PRIVAT") Set templatesheet2 = TemplateBook.Sheets("ERHVERV") 'Indsæt alle navnene på de projektmapper der skal udfyldes AllBooks = Array("01 Aabenraa.xls", "02 Aalborg.xls", "03 Esbjerg.xls", "04 Herning.xls", "05 Horsens.xls", "06 Kolding.xls", "07 København.xls", "08 Odense.xls", "09 Padborg.xls", "10 Svendborg.xls", "11 Sønderborg.xls", "12 Tønder.xls", "13 Varde.xls", "14 Vejle.xls", "15 Århus.xls") 'Indsæt navnene på de ark der skal have nyt indhold shName1 = "PRIVAT" shName2 = "ERHVERV" 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 04-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
AI bliver først for alvor en del af arbejdet, når teknologien integreres i den måde, vi arbejder på. At have adgang til AI betyder ikke nødvendigvis, at medarbejderne er klar til at bruge den.
Sub copySheetContents() Dim objWBrecievingBook As Excel.Workbook Dim objWBSourceBook As Excel.Workbook Dim objWSRecivingSheet As Excel.Worksheet Dim objWSSourceSheet As Excel.Worksheet
Dim shName1 As String
Dim AllBooks Dim x As Long
On Error GoTo HandleErr Set objWBrecievingBook = ThisWorkbook
'Udfyld med de rigtige arknavne fra skabelonen Set objWSRecivingSheet = objWBrecievingBook.Sheets("Ark1")
'Indsæt alle navnene på de projektmapper der skal udfyldes fra
Jeg skal lige høre dig. Det du kalder "Ark1" er det arket jeg kopier fra eller til? Hvor skal jeg skrive stien til de 18 ark der skal kopiers fra og hvor skal stien til det ark der skal kopieres til stå?
Denne linje indeholder de filer der skal kopieres fra. I dette eksempel er der 3 filer : AllBooks = Array("Book1.xls", "Book2.xls", "Book3.xls")
Denne linje indeholder det ark der skal modtage data fra de 18 filer. Det skal være et ark i den fil, hvor du skal lægge denne kode: Set objWSRecivingSheet = objWBrecievingBook.Sheets("Ark1")
Denne linje åbner de filer, der indeholder de data der skal kopieres sammen: Set objWBSourceBook = Workbook.Open(AllBooks(x))
Linjen kan udvides så den også indeholder en sti til de 18 filer: Set objWBSourceBook = Workbook.Open("c:\mappe1\mappe2\" & AllBooks(x))
Linjen her vælger arket med dine kildedata, i den fil der lige er blevet åbnet: Set objWSSourceSheet = objWBSourceBook.Sheets("Ark1")
OK, nu her jeg fundet fejlen, denne kode skulle kunne gøre det :
Sub copySheetContents() Dim objWBrecievingBook As Excel.Workbook Dim objWBSourceBook As Excel.Workbook Dim objWSRecivingSheet As Excel.Worksheet Dim objWSSourceSheet As Excel.Worksheet
Dim shName1 As String
Dim AllBooks Dim x As Long
On Error GoTo errorhandler Set objWBrecievingBook = ThisWorkbook
'Udfyld med de rigtige arknavne fra skabelonen Set objWSRecivingSheet = objWBrecievingBook.Sheets("Ark1")
'Indsæt alle navnene på de projektmapper der skal udfyldes fra
For x = LBound(AllBooks) To UBound(AllBooks) Set objWBSourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & AllBooks(x)) Set objWSSourceSheet = objWBSourceBook.Sheets("Ark1")
objWSSourceSheet.Range("A1:BF13").Copy Destination:=objWSRecivingSheet.Cells(65536, 1).End(xlUp) objWBSourceBook.Close False Next
Hvis jeg nu vil have en række i mellemrum og gerne vil have der kun tages fra B1, hvad skal jeg så ændre? Jeg har prøvet at ændre objWSSourceSheet.Range("A1:BF13").Copy.... til objWSSourceSheet.Range("B1:BF13").Copy uden held!
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
