Opdatere anden workbook, tilfoeje (overskrive) og sortere (Macro)

Sheet1 i Content.xls er det ark, der skal opdateres

Jeg har valgt at loese det paa en helt anden maade. Vha. hvad Bak skrev i
http://www.eksperten.dk/spm/279147
saa laver jeg en macro der automatisk eftersproger vaerdierne af B3 og B2 i alle xls filer i en mappe.
A) Hvordan faar jeg macroen til at kigge i alle ark. Mine ark hedder part0, part1, part2, part3, op til i alt 10. Nogle har kun een part, andre har flere parts.
B) Hvordan sorterer jeg til slut alfabetisk efter indhold i B3.

A & B Det er det sidste jeg mangler, saa er problmet loest. Jeg giver stadig 60 points

Sub GetValuesFromClosedFiles()
Dim FS As FileSearch
Dim FilePath As String
Dim i As Integer, j As Integer
Dim v As Variant
Dim Cells2Get()
Const Filespec = "*.xls"              'udfyldes af bruger Filtype
Const sheet = "Sheet1"                'udfyldes af bruger Arknavn

FilePath = "C:\test\"                'udfyldes af bruger Startfolder
Cells2Get = Array("B3", "B2") 'udfyldes af bruger Celler, der skal hentes
Application.ScreenUpdating = False
Set FS = Application.FileSearch
With FS
  .LookIn = FilePath
  .Filename = Filespec
  '.SearchSubFolders = True          'skal underfoldere også søges
  .Execute
  If .FoundFiles.Count = 0 Then
      MsgBox ("Ingen filer fundet")
      Exit Sub
  End If
  For i = 1 To .FoundFiles.Count
    v = Split(.FoundFiles(i), Application.PathSeparator)
    FilePath = Left(.FoundFiles(i), InStrRev(.FoundFiles(i), Application.PathSeparator))
    ActiveCell.Offset(i - 1, 0) = FilePath & v(UBound(v))
    For j = 0 To UBound(Cells2Get)
      ActiveCell.Offset(i - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
  Next
End With
Application.ScreenUpdating = False
End Sub

Private Function GetValue(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(range_ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function

Det vil vaere fint hvis det som makroen skriver i kolonne A bliver lavet til hyperlinks

alle ark, sådan

    For Each ws In Worksheets
If left(ws.Name,4)= "Part" Then
'din kode

end if
next

der manglede lige en linie

  For Each ws In Worksheets
If left(ws.Name,4)= "Part" Then
Sheets(ws.Name).Select
'din kode

end if
next

-> kabbak. Jeg kan ikke finde ud af hvor jeg skal saette det ind. Kan du vise mig det? Hvad med Const sheet = "Sheet1" (Const sheet = "part1"), skal det aendres? Jeg proevede at saette hvad du skrev ind ind i funktionen. Det virkede ikke.

Det kan det heller ikke umiddelbart.
Problemet ligge i at man ikke kan aflæse hvor mange Ark der er i en liúkket fil og heller ikke hvad de hedder.

Her er en lille omskrivning af makroen.
Det forudsætter at alle arknavne starter med "part" efterfulgt af et nummer mellem 0 og 20 og at de ligger sekventiel med en ubrudt række.
Forståes så der ligger part0, part1, part2 part3 osv. op til part20.
hvis der er mindre end 20 gør det ikke noget.

Option Explicit

Sub GetValuesFromClosedFiles()
Dim FS As FileSearch
Dim FilePath As String
Dim i As Integer, j As Integer
Dim v As Variant
Dim Cells2Get()
Dim x As Long, y As Long
Dim sheet As String
Dim temp
Const Filespec = "*.xls"              'udfyldes af bruger Filtype
'Const sheet = "Sheet1"                'udfyldes af bruger Arknavn

FilePath = "C:\test\"                'udfyldes af bruger Startfolder
Cells2Get = Array("B3", "B2") 'udfyldes af bruger Celler, der skal hentes
Application.ScreenUpdating = False
Set FS = Application.FileSearch
With FS
  .LookIn = FilePath
  .Filename = Filespec
  '.SearchSubFolders = True          'skal underfoldere også søges
  .Execute
  If .FoundFiles.Count = 0 Then
      MsgBox ("Ingen filer fundet")
      Exit Sub
  End If
  For i = 1 To .FoundFiles.Count
        v = Split(.FoundFiles(i), Application.PathSeparator)
        FilePath = Left(.FoundFiles(i), InStrRev(.FoundFiles(i), Application.PathSeparator))
       
        For x = 0 To 20
            sheet = "part" & x
            For j = 0 To UBound(Cells2Get)
                temp = GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
                If IsError(temp) Then GoTo NoSheetWithThisName
                ActiveCell.Offset(y, j + 1) = temp
            Next
            ActiveCell.Offset(y, 0) = FilePath & v(UBound(v)) & "  " & sheet
            y = y + 1
        Next
NoSheetWithThisName:
  Next

End With
Application.ScreenUpdating = False
End Sub

Private Function GetValue(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(range_ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function

Tak bak, dit forslag er fint, jeg udviklede samtidig med dig denne macro, der endda virker med romertal - Alternativt kan sheet saettes til "part" & x (laegge 1 til hver gang og koere optil f.eks 20).

Du faar ogsaa dine points, da din loesning er mere universiel.

Sub GetValuesFromClosedFiles()
Dim FS As FileSearch
Dim FilePath As String
Dim i As Integer, j As Integer
Dim v As Variant
Dim Cells2Get()
Dim sheet As String
Const Filespec = "*.xls"              'udfyldes af bruger Filtype
             
FilePath = "C:\test\" 'udfyldes af bruger Startfolder
Cells2Get = Array("B2", "B3")  'udfyldes af bruger Celler, der skal hentes DER KAN Skrives flere celler efterfulgt af komma
Application.ScreenUpdating = False
Set FS = Application.FileSearch
With FS
  .LookIn = FilePath
  .Filename = Filespec
  '.SearchSubFolders = True          'skal underfoldere også søges
  .Execute
  If .FoundFiles.Count = 0 Then
      MsgBox ("Ingen filer fundet")
      Exit Sub
  End If

  For i = 1 To .FoundFiles.Count
    i5 = i * 5 - 4
    v = Split(.FoundFiles(i), Application.PathSeparator)
    FilePath = Left(.FoundFiles(i), InStrRev(.FoundFiles(i), Application.PathSeparator))
    ActiveCell.Offset(i5 - 1, 0) = FilePath & v(UBound(v))
    sheet = "part0"
    For j = 0 To UBound(Cells2Get)
    ActiveCell.Offset(i5 - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
 
    ActiveCell.Offset(i5 + 1 - 1, 0) = FilePath & v(UBound(v))
    sheet = "parti"
    For j = 0 To UBound(Cells2Get)
    ActiveCell.Offset(i5 + 1 - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
    ActiveCell.Offset(i5 + 2 - 1, 0) = FilePath & v(UBound(v))
    sheet = "partii"
    For j = 0 To UBound(Cells2Get)
    ActiveCell.Offset(i5 + 2 - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
    ActiveCell.Offset(i5 + 3 - 1, 0) = FilePath & v(UBound(v))
    sheet = "partiii"
    For j = 0 To UBound(Cells2Get)
    ActiveCell.Offset(i5 + 3 - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
    ActiveCell.Offset(i5 + 4 - 1, 0) = FilePath & v(UBound(v))
    sheet = "partiv"
    For j = 0 To UBound(Cells2Get)
    ActiveCell.Offset(i5 + 4 - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
  Next
End With
Application.ScreenUpdating = False
End Sub

ved at erstatte denne linie i min makro:

sheet = "part" & x
med
sheet = IIf(x = 0, "part0", "part" & Application.Roman(x))

kører den ogå med romertal