25. august 2008 - 12:12Der er
24 kommentarer og 1 løsning
Sammenlægning af celler i eksterne filer
Hej,
Jeg har et noget kompiceret problem, som jeg nu over nogen dage har forsøgt at løse uden held. Jeg håber derfor at der er nogen her på siden, der kan hjælpe mig....:
Jeg har en salgsfil som udfyldes af sælgeren for hver kunde. Filen består af 6 kategorier som hver har deres ark i filen. For hver kategori er der yderligere underkategorier og for hver af disse underkategorier er der optil 7 størrelser. Salget anføres under den pågædende størrelse.
Eks: Ark 1: Bukser - underkategori: Korte bukser: Str: 1 (D20) Str: 2 (E20) etc. Hvis sælgeren har salg 3 korte bukser i størrelse 2 anføres 3 is celle E20.
Jeg ønsker nu en masterfil, der kan sammenlægge alle salg fra alle salgsfiler. Tanken er at masterfilen, som er en identisk kopi af salgsfilen, skal gå ind i folderen, hvor salgsfilerne er gemt (Jeg kender ikke navne på disse filer eller antallet af filer, men blot folderen hvor de er gemt) og lægge alle cellerne sammen for alle salgsfiler, således at jeg kan se det totale salg af f.eks. korte bukser (Sheet1, E20).
Jeg har på nuværende tidspunkt flg. kode, som kun formår at lægge én celle sammen, men da jeg ikke ønsker at kalde koden 1000 gange (for alle str. og underkategorier), håber jeg at der findes en anden mulighed f.eks Array(), men er ikke så skarp udi VB. Håber nogen kan hjælpe:-)
Sub Get_Value_From_A111() Dim lCount As Long
Dim wbResults As Workbook Dim wbThis As Workbook Dim dblValue As Double Dim ClValue
WbCnt = 0 With .FileSearch .NewSearch 'Change path to suit .LookIn = "C:\Salg\PR\PR_new" 'Sales folder .FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder For lCount = 1 To .FoundFiles.Count 'Loop through all. 'Open Workbook x and Set a Workbook variable to it Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0) 'check that the cell contains a number
ClValue = wbResults.Worksheets(1).Cells(20, 4).Value If IsNumeric(ClValue) Then 'sum the values contained in D20 of the first sheet in each workbook dblValue = dblValue + ClValue wbResults.Close SaveChanges:=False 'don't save 'write result to master workbook wbThis.Worksheets(1).Cells(20, 4).Value = dblValue
Else: wbResults.Close SaveChanges:=False GoTo skipped End If
WbCnt = WbCnt + 1 skipped: Next lCount End If
End With
On Error GoTo 0 .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With
I et inbound callcenter, hvor identiteten på den, der ringer ind, skal bekræftes, kan kontrollen nu foregå i telefonkøen. Det understøtter fem centrale KPI'er for callcentre.
WbCnt = 0 With .FileSearch .NewSearch 'Change path to suit .LookIn = "C:\Salg\PR\PR_new" 'Sales folder .FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder For lCount = 1 To .FoundFiles.Count 'Loop through all. 'Open Workbook x and Set a Workbook variable to it Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
' hvis vi siger at værdierne ligger i række 20 og i de første 10 kolonner, så virker dette
ClValue = wbResults.Worksheets(1).Range(Cells(20, 1), Cells(20, 10)) '***** Putter 10 celler i et array wbResults.Close SaveChanges:=False 'don't save ' lukker mappen For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(X)) Then 'check that the cell contains a number wbThis.Worksheets(1).Cells(20, X).Value = ClValue(X) 'write result to master workbook
' slut på ændring
End If Next
WbCnt = WbCnt + 1 skipped: Next lCount End If
End With
On Error GoTo 0 .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With
For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(X)) Then 'check that the cell contains a number wbThis.Worksheets(1).Cells(20, X).Value = ClValue(X) 'write result to master workbook
til
For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(1,X)) Then 'check that the cell contains a number wbThis.Worksheets(1).Cells(20, X).Value = ClValue(1,X) 'write result to master workbook
WbCnt = 0 With .FileSearch .NewSearch 'Change path to suit .LookIn = "C:\Salg\PR\PR_new" 'Sales folder .FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder For lCount = 1 To .FoundFiles.Count 'Loop through all. 'Open Workbook x and Set a Workbook variable to it Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
' hvis vi siger at værdierne ligger i række 20 og i de første 10 kolonner, så virker dette
ClValue = wbResults.Worksheets(1).Range(Cells(20, 1), Cells(20, 10)) '***** Putter 10 celler i et array wbResults.Close SaveChanges:=False 'don't save ' lukker mappen For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(1, X)) Then 'check that the cell contains a number wbThis.Worksheets(1).Cells(20, X).Value = wbThis.Worksheets(1).Cells(20, X).Value + ClValue(1, X) 'write result to master workbook
' slut på ændring
End If Next
WbCnt = WbCnt + 1 skipped: Next lCount End If
End With
On Error GoTo 0 .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With
Dette fungerer perfekt. Problemet er blot at jeg ikke kun har række 20, men også 23, 26, 29.... ned til 99 som skal lægges sammen. Samtidig har jeg dette for alle 6 ark (produkt typer). Er løsningen på dette blot at kopiere koden og ændre række nr og ark nummer så mange gange det er nødvendigt eller er der en lettere måde...?
En anden ting jeg bemærker er at programmet hele tiden lægger til den nuværende sum i master filen. Dvs. når jeg kører programmet og der f.eks. allerede står 4 i D20 i master filen og det sammenlagte tal for salgsfilerne for D20 er 5, vil den skrive 9 og ikke 5, hvis jeg kører den igen vil den skrive 14 etc. Er der nogen måde hvorpå den kan overskrive den nuværende værdi i masterfilen?
For I = 1 To 6 ' Ark For Y = 20 To 100 Step 3' Række ClValue = wbResults.Worksheets(I).Range(Cells(Y, 1), Cells(Y, 10)) '***** Putter 10 celler i et array wbResults.Close SaveChanges:=False 'don't save ' lukker mappen For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(1, X)) Then 'check that the cell contains a number wbThis.Worksheets(I).Cells(Y, X).Value = wbThis.Worksheets(1).Cells(Y, X).Value + ClValue(1, X) 'write result to master workbook End If Next Next Next
Jeg har 6 ark på masterfilen, da den er en eksakt kopi af salgsfilen. Desværre hopper den ikke konsekvent 3 over - i nogen tilfælde hopper den 4 over. Men kunne man evt. lave et array der hedder noget i retning af Range(Cells(20, 1), Cells(99, 10)) - det ville værre helt i orden at den lagde cellerne sammen hvor der ingen data er da dette jo blot vil give 0.
WbCnt = 0 With .FileSearch .NewSearch 'Change path to suit .LookIn = "C:\Salg\PR\PR_new" 'Sales folder .FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then 'Workbooks in folder For lCount = 1 To .FoundFiles.Count 'Loop through all. 'Open Workbook x and Set a Workbook variable to it Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
' hvis vi siger at værdierne ligger i række 20 og i de første 7 kolonner, så virker dette
For i = 1 To 6 ' Ark For Y = 20 To 100 Step 1 ' Række ClValue = wbResults.Worksheets(i).Range(Cells(Y, 1), Cells(Y, 7)) '***** Putter 7 celler i et array wbResults.Close SaveChanges:=False 'don't save ' lukker mappen For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(1, X)) Then 'check that the cell contains a number wbThis.Worksheets(i).Cells(Y, X).Value = wbThis.Worksheets(1).Cells(Y, X).Value + ClValue(1, X) 'write result to master workbook End If Next Next Next
WbCnt = WbCnt + 1 skipped: Next lCount End If
End With
On Error GoTo 0 .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With
End Sub
Den kommer nu med værdier i alle arkene, men de ser ikke korrekte ud. I mine to test salgsfiler har jeg iøjeblikket kun værdier i sheet 1 D20:I20, men alligevel kommer den med værdier for stort set all celler. Undskyld de mange spørgsmål, men hvordan sætter jeg den til at slette data i masterfilen ved opsart af koden....?
Jeg måtte give arkene, det rigtige navn, for at det virkede korrekt ved mig, så derfor er der arknavne i koden.
Option Explicit Option Base 1
Sub Get_Value_From_A111() Dim lCount As Long Dim wbResults As Workbook Dim wbThis As Workbook Dim dblValue As Double Dim ClValue As Variant '******* rettet Dim X As Integer, I As Integer, Y As Integer, AD As String ' NY Dim WbCnt As Long Dim Rk(6) As Variant Set wbThis = ThisWorkbook
With Application .ScreenUpdating = False ' .DisplayAlerts = False .EnableEvents = False ' On Error Resume Next dblValue = 0
WbCnt = 0 With .FileSearch .NewSearch 'Change path to suit .LookIn = "C:\Salg\PR\PR_new" 'Sales folder .FileType = msoFileTypeExcelWorkbooks If .Execute > 0 Then 'Workbooks in folder For lCount = 1 To .FoundFiles.Count 'Loop through all. 'Open Workbook x and Set a Workbook variable to it Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
For I = 1 To 6 ' Ark For Y = 1 To UBound(Rk(I)) ' Række AD = "A" & Rk(I)(Y) & ":G" & Rk(I)(Y) ClValue = wbResults.Worksheets("Ark" & I).Range(AD) '***** Putter 7 celler i et array For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(1, X)) And Not IsEmpty(ClValue(1, X)) Then 'check that the cell contains a number and not empty wbThis.Worksheets("Ark" & I).Cells(Rk(I)(Y), X).Value = wbThis.Worksheets("Ark" & I).Cells(Rk(I)(Y), X).Value + ClValue(1, X) 'write result to master workbook End If Next ClValue = Empty Next Next
wbResults.Close SaveChanges:=False 'don't save ' lukker mappen WbCnt = WbCnt + 1 skipped: Next lCount End If
End With ' On Error GoTo 0 .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With
Den giver mig en runtime error når jeg kører koden. Koden formår at slette indholdet i masterfilen (dog blot for det første sheet), men altså ikke at lægge de nye tal ind.
Den giver mig vel også et problem med navngivning af arkene i salgsfilerne, da disse ark alle har forskellige navne i henhold til produkttype og altså ikke hedder ark1, ark2 etc. eller lign. med fortløbende nummerering - de hedder f.eks. Bukser, Trøjer etc.. Dette er nu ikke grunden til ovenstående error, da jeg har rettet alle ark navnene i mine testfiler til Ark1, Ark2 osv.
OK jeg har sat arkene i et array, så kan du rette dem der, de skal være ens både i salgsfilerne og resultatfilen
Husk at få de 2 linjer med , der står over proceduren, når du kopierer ind.
Option Explicit Option Base 1
Sub Get_Value_From_A111() Dim lCount As Long Dim wbResults As Workbook Dim wbThis As Workbook Dim dblValue As Double Dim ClValue As Variant '******* rettet Dim X As Integer, I As Integer, Y As Integer, AD As String, Ark As Variant ' NY Dim WbCnt As Long Dim Rk(6) As Variant Set wbThis = ThisWorkbook Ark = Array("Ark1", "Ark2", "Ark3", "Ark4", "Ark5", "Ark6") ' ret til dine ark
With Application .ScreenUpdating = False ' .DisplayAlerts = False .EnableEvents = False ' On Error Resume Next dblValue = 0
WbCnt = 0 With .FileSearch .NewSearch 'Change path to suit ' .LookIn = "C:\Salg\PR\PR_new" 'Sales folder .LookIn = "C:\data1" 'Sales folder .FileType = msoFileTypeExcelWorkbooks If .Execute > 0 Then 'Workbooks in folder For lCount = 1 To .FoundFiles.Count 'Loop through all. 'Open Workbook x and Set a Workbook variable to it Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
For I = 1 To 6 ' Ark For Y = 1 To UBound(Rk(I)) ' Række AD = "A" & Rk(I)(Y) & ":G" & Rk(I)(Y) ClValue = wbResults.Worksheets(Ark(I)).Range(AD) '***** Putter 7 celler i et array For X = 1 To UBound(ClValue, 2) 'looper igennem kolonner If IsNumeric(ClValue(1, X)) And Not IsEmpty(ClValue(1, X)) Then 'check that the cell contains a number and not empty wbThis.Worksheets(Ark(I)).Cells(Rk(I)(Y), X).Value = wbThis.Worksheets(Ark(I)).Cells(Rk(I)(Y), X).Value + ClValue(1, X) 'write result to master workbook End If Next ClValue = Empty Next Next
wbResults.Close SaveChanges:=False 'don't save ' lukker mappen WbCnt = WbCnt + 1 skipped: Next lCount End If
End With ' On Error GoTo 0 .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With
Unskyld det er mig der er lidt langsom - har rettet den til at tage alle 7 celler med. Den var sat fra A:G men skulle rettes til D:J. Endnu engang mange tak for hjælpen - det var helt perfekt.
Og så til pointgivningen - jeg er ny bruger, men er det noget med at du skal poste et svar for at jeg kan acceptere dette...? :-)
Jeg giver et svar,du markerer mit navn i boksen til venstre og trykker accepter.
;-))
Synes godt om
Ny brugerNybegynder
Din løsning...
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.
