12. august 2013 - 15:27Der er
11 kommentarer og 1 løsning
Konsolidering af dokumenter med både tekst og tal
Hej
Jeg har en opgave hvor jeg har 9 dokumenter, hvor der løbende indføres nogle data i, og disse 9 forskellige dokumenter ønsker at samle i 1 dokument, der løbende opdateres via kæder, så ledes at det ene dokument hele tiden er up to date..
Nogle af felterne er tal, nogle dato og andre er tekst.
De har alle samme overskrifter på kollonerne.
Jeg har prøvet med Konsolider, men så trækker arkene kun tal over.
1. Jeg har 9 dokumenter i formatet xlsx-> HVK, SVM, KAS, SLA, VOR, JPL, SJO, JON, BNH
2. Hvert dokument registrerer noget forskellige "aftaler" på et ark hver, lad os kalde dem --> A, B og C
3. I disse dokumenter registreres en dato, en observation(i tekst), og der sættes et tal i en ud af 3 koloner, afhængigt af udfaldet(Klage, afvist, udbedret).
4. Jeg ønsker så nu at have ET samlet dokument hvor jeg trækker de 9 sammen. Dvs...alle arkene fra hvert af de 9 konsolideres i et Excel dokument jeg opretter til formålet. Dette Excel dokument skal have ark A B og C...hvor de andre 9 så er samlet
5. Næste gang jeg åbner mit "master dokument" skal den konsolidere dokumenterne igen på ny, således at master dokumentet hele tiden er opdateret...
Dim wbSource As Workbook, wbTarget As Workbook Dim wsSource As Worksheet, wsTarget As Worksheet Dim curPath As String curPath = ThisWorkbook.Path & "\"
Dim tmpFile As String Dim lastRow As Long, lastcol As Long, curRow As Long Dim arrayFiles As Variant, arraySheets As Variant, arrSize As Long Dim C As Long, countLines As Long Dim S As Long, F As Long, R As Long
Set wbTarget = ActiveWorkbook
If Not wbTarget.Name = "overblik.xlsm" Then MsgBox "Makro køres fra forkert fil - luk denne fil og åbn den rigtige ;-) " Exit Sub End If
' Danner liste over hvilke filer der skal behandles Sheets("Admin").Select lastRow = Range("A65536").End(xlUp).Row arrSize = lastRow - 1 ReDim arrayFiles(arrSize)
' behandler filer 1 for 1 For C = 1 To arrSize arrayFiles(C) = Cells(1 + C, 1) Next C
' Danner liste over hvilke faner der skal behandles Sheets("Admin").Select lastRow = Range("C65536").End(xlUp).Row arrSize = lastRow - 1 ReDim arraySheets(arrSize)
' behandler filer 1 for 1 For C = 1 To arrSize arraySheets(C) = Cells(1 + C, 3) Next C
' Checker om filer på listen finds i mappen
For F = 1 To UBound(arrayFiles) tmpFile = arrayFiles(F) If Not Dir(curPath & tmpFile) > "" Then MsgBox "Kan ikke finde filen: " & tmpFile & "?", vbCritical Exit Sub End If Next F
' Slettes gamle data på arkene i konsolideringsfilen
For S = 1 To UBound(arraySheets) Dim wsSlet As Worksheet Set wsSlet = wbTarget.Worksheets(arraySheets(S)) wsSlet.Activate Range("A3:P50000").ClearContents Next S
' ### Gør klar til at åbne filer i listen herover, 1 for 1 For F = 1 To UBound(arrayFiles) tmpFile = curPath & arrayFiles(F)
Set wbSource = Workbooks.Open(Filename:=tmpFile, ReadOnly:=True) ' kildefilen er nu åben
' ### Nu skal de data-ark i filen læses og data skal indlæses For S = 1 To UBound(arraySheets)
Set wsSource = wbSource.Worksheets(arraySheets(S)) Set wsTarget = wbTarget.Worksheets(arraySheets(S)) curRow = wbTarget.Worksheets(arraySheets(S)).Range("A65536").End(xlUp).Row + 1 If curRow < 4 Then curRow = 3
Application.StatusBar = "Behandler..... " & tmpFile & " Fane ....." & arraySheets(S) ' og nu de enkelte linier på hver fane For R = 3 To lastRow For C = 1 To lastcol wsTarget.Cells(curRow, C) = wsSource.Cells(R, C) Next C wsTarget.Cells(curRow, C) = tmpFile curRow = curRow + 1 countLines = countLines + 1 Next R Next S
' Nu er fanerne gennemlæst ' her lukkes kildefilen igen uden at der er sket ændringer i den wbSource.Close savechanges:=False Application.StatusBar = "" Next F
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.