29. januar 2009 - 19:05Der er
2 kommentarer og 1 løsning
Genemsøgning af Excelfiler for at kopiere data over i ny Excelfil
Hej
Jeg er novice på Excel området, så be' om hjælp. Og pt. kender jeg iøvrigt ikke alle detaljer i opgaven ;)
Jeg har et stort antal excelfiler (2000+) som har samme struktur. Nogle af dataene skal findes frem og kopieres over i et andet excelark, så jeg ender med at have alle de ønskede data i en enkelt fil, som så bagefter skal behandles videre med et andet værktøj.
Det må kunne laves i VBA koden, men hvordan kalder man kode inde i Excel? (er sikkert meget banalt, sorry)
Jeg kan sagtens lave et loop igennem alle filerne, men hvordan får jeg åbnet den enkelte fil, søgt dataene frem og kopieret over i den nye?
Det er selvfølgelig noget der skulle ha' været færdigt i forgårs.
Public Sub HentData() Dim FolderName As String, I As Integer, NO As Integer, strFilnavn() As Variant Dim Data() As Variant, DCeller As Variant Dim RW As Integer, J As Integer DCeller = Array("C1", "C5", "F8", "D11", "E11", "F11", "D13", "E13", "F13", "J11") ' celler der indeholder de værdier, som vi ønsker hentet FolderName = "C:\Data" ' rettes til If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\" NO = 1 ReDim Preserve strFilnavn(NO) strFilnavn(NO) = Dir(FolderName & "*.xls") ' Hent den første filnavn. Do While strFilnavn(NO) <> "" ' Start løkken If strFilnavn(NO) <> "." And strFilnavn(NO) <> ".." Then NO = NO + 1 ReDim Preserve strFilnavn(NO) End If strFilnavn(NO) = Dir ' Hent næste filnavn. Loop NO = NO - 1 ReDim Data(NO, UBound(DCeller)) Application.ScreenUpdating = False For I = 1 To NO Workbooks.Open Filename:=FolderName & strFilnavn(I) For J = 0 To UBound(DCeller) Data(I, J) = Worksheets("Siden der hentes fra").Range(DCeller(J)) Next ActiveWorkbook.Close False Next I RW = ThisWorkbook.Worksheets("siden der gemmes på").Range("A65536").End(xlUp).Row + 1 ThisWorkbook.Worksheets("siden der gemmes på").Range(Cells(RW, 1), Cells(RW + NO, UBound(DCeller) + 1)) = Data
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.
