Sub TælSammen() Dim A As Integer, B As Integer, Data As Variant, Res As Variant B = Range("B65536").End(xlUp).Row ' finder sidste række med data Data = Range("A1:B" & B) ' Varenummer kolonne A og Antal kolonne B Res = Range("C1:D" & B) ' Skriver resultatet i Kolonne C og D
For T = 1 To UBound(Data) For i = 1 To UBound(Res) If Res(i, 1) = Data(T, 1) Then Res(i, 2) = Res(i, 2) + Data(T, 2) GoTo Næste End If If Res(i, 1) = "" Then Res(i, 1) = Data(T, 1) Res(i, 2) = Res(i, 2) + Data(T, 2) GoTo Næste End If Next Næste: Next Range("C1:D" & B) = Res 'Skriver i C og D kolonnen 'Range("A1:B" & B) = Res ' byttes med ovenstående OVERSKRIVES A og B kolonnen End Sub
Jepp!, kan du hjelpe meg med et problem til? skal ha med vare beskrivlese også i kolonne C, må da kjøre makroen på den gamle tabellen,men med kolonne C som varebeskrivelse,,,, hva må utbedres i makroen da???
kan opprette et nytt spm på det så du får dine poeng!
Sub TælSammen() Dim A As Integer, B As Integer, Data As Variant, Res() As Variant B = Range("B65536").End(xlUp).Row ' finder sidste række med data Data = Range("A1:C" & B) ' Varenummer kolonne A , Antal kolonne B, C varebeskrivelse ReDim Res(B, 2) For T = 1 To UBound(Data) For I = 1 To UBound(Res) If Res(I, 0) = Data(T, 1) Then Res(I, 1) = Res(I, 1) + Data(T, 2) GoTo Næste End If If Res(I, 1) = "" Then Res(I, 0) = Data(T, 1) Res(I, 2) = Data(T, 3) Res(I, 1) = Res(I, 1) + Data(T, 2) GoTo Næste End If Next Næste: Next For A = 0 To 2 For I = 1 To UBound(Res) Cells(I, 4 + A) = Res(I, 0 + A) 'Skriver i D, E og F kolonnen If Res(I, 0 + A) = "" Then Exit For Next Next End Sub
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.