Kopiere data fra 100 excel filer til en excel fil.

Nedenstående kode lader dig vælge den folder, hvor certifikat-filerne er placeret. Start koden GetDataFromCertificates, mens du står i arket med serienumrene (hovedtabellen).

Hvis du bruger Excel 2007, og dine certifikat-filer dermed hedder .xlsx og ikke .xls til "efternavn", skal du rette det i koden.

*****************
Public Sub GetDataFromCertificates()
    Dim objWS As Worksheet
    Dim objWB_Certificate As Workbook
    Dim objWS_Certificate As Worksheet
    Dim objDialog As FileDialog
    Dim strFolder As String
    Dim strFileName As String
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim l As Integer
    Dim lngRow As Long
   
    Set objWS = ActiveSheet
    Set objDialog = Application.FileDialog(msoFileDialogFolderPicker)
   
    j = 1
    k = 5
   
    With objDialog
        .Title = "Vælg folderen med certifikaterne"
        If .Show = -1 Then
            strFolder = .SelectedItems(1)
           
            For i = 1 To 100
                strFileName = strFolder & "\Mappe " & j & "-" & k & ".xls"
                If Dir(strFileName) <> "" Then
                    Set objWB_Certificate = Workbooks.Open(strFileName, False, ReadOnly:=True)
                    For l = 1 To 5
                        Set objWS_Certificate = objWB_Certificate.Sheets("Ark (" & CStr(l) & ")")
                        If SerialNumberFound(objWS, CStr(objWS_Certificate.Range("B20").Text), lngRow) = True Then
                            objWS.Cells(lngRow, "N") = objWS_Certificate.Range("B17")
                            objWS.Cells(lngRow, "O") = objWS_Certificate.Range("B27")
                            objWS.Cells(lngRow, "P") = objWS_Certificate.Range("B28")
                        Else
                            objWS.Cells(lngRow, "N") = ""
                            objWS.Cells(lngRow, "O") = ""
                            objWS.Cells(lngRow, "P") = ""
                        End If
                    Next l
                    objWB_Certificate.Close False
                End If
                j = j + 5
                k = k + 5
            Next i
        End If
    End With
   
    Set objWS = Nothing
    Set objWB_Certificate = Nothing
    Set objWS_Certificate = Nothing
    Set objDialog = Nothing
End Sub

Public Function SerialNumberFound(objWS As Worksheet, strSerial, lngRow) As Boolean
'finder rækken med serienummeret i hovedtabellen hvis det findes
    Dim objColumn As Range
    Dim objCell As Range
   
    Set objColumn = objWS.Columns("A:A").CurrentRegion
   
    For lngRow = 1 To objColumn.Cells.Count
        If objColumn.Cells(lngRow) = strSerial Then
            SerialNumberFound = True
            Exit For
        End If
    Next lngRow
End Function

******************

Tak word-hajen,

Det fungerer næsten 100%, der er mog 2 ting som jeg har problemer med:

1. i linjen "If objColumn.Cells(lngRow) = strSerial Then" er strSerial ikke Integer, det er den værdi på venstre side tilgengæld, derfor har jeg ændret linjen til følgende:
            "If objColumn.Cells(lngRow) = CInt(strSerial) Then"
Det løste problemet.


2. "Set objColumn = objWS.Columns("A:A").CurrentRegion"
Denne linje skulle vælge alle serienummer, altså hele søjle A og kun søjle A. Problemet er at den vælger hele arket. Dvs. også søjle B, C, D, E.....M, da der også står værdier der.

Hvordan kan jeg ændre koden således at den kun kigger i søjlen A1? Alternativet er at jeg tømmer alle søjler bortset fra A1, kører markøren og så kopiere de tømte værdier tilbage, men det er alt for besværligt.

Hilsen
Sarben

1. Super. Jeg kan bare ikke vide, om serienummeret er numerisk :-)
2. Selvfølgelig. Navngiv din kolonne med serienumre og ændr linjen til

Set objColumn = ActiveWorkbook.Names("SerialNumber").RefersToRange 'udskift navnet med det, som du har angivet for kolonnen