03. april 2009 - 09:14
Der er
1 kommentar og
1 løsning
Kopiering af værdier fra subtotaler
Jeg har en liste på ark1 med 6 kolonner.
A: Nr
B: Type (Type1, Type2 eller Type3)
C: Beløb
D: Hvis værdien i B=Type1 flytter jeg værdien ud i denne kolonne.
E: Hvis værdien i B=Type2 flytter jeg værdien ud i denne kolonne.
F: Hvis værdien i B=Type3 flytter jeg værdien ud i denne kolonne.
Herefter laver jeg subtotaler når Nr i A skifter under kolonne D, E & F.
På ark 2 har jeg i kolonne A de samme nr som på ark 1 og vil gerne have flyttet værdier fra subtotalerne ud for nr, og det går fint indtil jeg opdater listen på ark 1 og cellerne rykker sig igen.
Jeg har ca. 25.000 linier i min liste der bliver samlet til ca. 100 subtotaler, så det er et stort arbejde at opdatere referencerne til subtotalerne hvergang.
03. april 2009 - 23:09
#2
Dim pNr
Dim ark1, formel, værdiF, værdiG, værdiH, værdiI, antalRækker1, antalRækker2
Dim ræk1, ræk2
Sub overførSubtotaler()
Application.ScreenUpdating = False
Rem Find antal rækker på ark1
ActiveWorkbook.Sheets("Ark1").Activate
antalRækker1 = findAntalrækker
Set ark1 = ActiveWorkbook.Sheets("Ark1")
Rem aktiver igen ark2
ActiveWorkbook.Sheets("Ark2").Activate
antalRækker2 = findAntalrækker
Rem Rem traverser ark2
ræk2 = 2
For ræk = ræk2 To antalRækker2
If Cells(ræk, 1) <> "" Then
pNr = Cells(ræk, 1)
ræk1 = findPnrPåArk1(pNr)
If ræk1 > 0 Then
With ark1
værdiF = .Cells(ræk1, 6)
værdiG = .Cells(ræk1, 7)
værdiH = .Cells(ræk1, 8)
værdiI = .Cells(ræk1, 9)
End With
With ActiveSheet
.Cells(ræk, 4) = værdiF
.Cells(ræk, 5) = værdiG
.Cells(ræk, 6) = værdiH
.Cells(ræk, 7) = værdiI
End With
End If
End If
Next ræk
Application.ScreenUpdating = False
MsgBox ("Overførlsel af subtotaler afsluttet")
End Sub
Private Function findAntalrækker()
findAntalrækker = ActiveCell.SpecialCells(xlLastCell).Row
End Function
Private Function findPnrPåArk1(pNr)
Dim subTotal
subTotal = CStr(pNr) + " Total" 'Id af række med projektnr + teksten Subtotal
With ark1.Range("B1:B" + CStr(antalRækker1))
Set c = .Find(subTotal, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
findPnrPåArk1 = c.Row
Else
findPnrPåArk1 = 0
End If
End With
End Function
