Kopiere regneark fra en lukket fil til et nyt / eks. regneark

Public Sub GetDataFromOtherWorkbook()
    Dim sFolder As String
    Dim sFileToOpen() As String
    Dim wbData As Workbook
    Dim rInsert As Range
    Dim lCount As Long

    Application.ScreenUpdating = False
    Set rInsert = Sheets("Ark1").Range("A1")
    sFolder = "D:\VBA-Test\"
   
    lCount = 1
    ReDim sFileToOpen(1 To lCount)
    sFileToOpen(lCount) = Dir(sFolder + "*.xls")
    Do While Not (sFileToOpen(lCount) = "")
        lCount = lCount + 1
        ReDim Preserve sFileToOpen(1 To lCount)
        sFileToOpen(lCount) = Dir
    Loop
    ReDim Preserve sFileToOpen(1 To lCount - 1)
    For lCount = 1 To UBound(sFileToOpen)
        Set wbData = Application.Workbooks.Open(Filename:=sFolder & sFileToOpen(lCount))
      Workbooks(sFileToOpen(lCount)).Sheets("investeringer").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        wbData.Close SaveChanges:=False
        Set wbData = Nothing
    Next lCount
   
    ' Clean up
    Set rInsert = Nothing
    Application.ScreenUpdating = True
End Sub

Makroen skal være i den excelfil de skal over i, da kommandoen "ThisWorkbook", henviser til den excelfil makroen er i.

Hvis du vil have filnavn på arkene, for at kende dem fra hinanden, så er koden her.


Public Sub GetDataFromOtherWorkbook()
    Dim sFolder As String
    Dim sFileToOpen() As String
    Dim wbData As Workbook
    Dim rInsert As Range
    Dim lCount As Long

    Application.ScreenUpdating = False
    Set rInsert = Sheets("Ark1").Range("A1")
    sFolder = "D:\VBA-Test\"
   
    lCount = 1
    ReDim sFileToOpen(1 To lCount)
    sFileToOpen(lCount) = Dir(sFolder + "*.xls")
    Do While Not (sFileToOpen(lCount) = "")
        lCount = lCount + 1
        ReDim Preserve sFileToOpen(1 To lCount)
        sFileToOpen(lCount) = Dir
    Loop
    ReDim Preserve sFileToOpen(1 To lCount - 1)
    For lCount = 1 To UBound(sFileToOpen)
        Set wbData = Application.Workbooks.Open(Filename:=sFolder & sFileToOpen(lCount))
      Workbooks(sFileToOpen(lCount)).Sheets("investeringer").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
      ActiveSheet.Name = sFileToOpen(lCount) & "_investeringer"
        wbData.Close SaveChanges:=False
        Set wbData = Nothing
    Next lCount
   
    ' Clean up
    Set rInsert = Nothing
    Application.ScreenUpdating = True
End Sub

Det er genialt - så enkelt og alligevel så stor værdi.

Takker for forslaget. Sidder i øjeblikket og undre mig over, hvordan jeg får tildelt point og lukket spørgsmålet.

mvh
Per

PS havde oprindelig afsat 100 point, men der stod kun 30, så den er ændret igen.

prøver igen ....

et svar ;-))

marker mit navn i boksen til venstre og accepter

tak for point