29. juli 2011 - 09:43
Der er
1 kommentar og
1 løsning
Opsamle navne fra forskellige celler og sætte dem ind i et kommentarfelt i excel
Jeg har en matrix med forskellige navne lodret og datoer vandret.
Alle navnene er tildelt en gruppe.
Jeg har så en liste (Array?) med grupperne, hvor jeg ønsker at få navnene vist i en kommentar i cellen, som har en markering ud for den pågældende dag i matrixen. Markeringen er et 1-tal.
Søger en løsning som går kolonnen igennem for en angivet dato og gemmer data i en form for liste for hver gruppe, som så til sidst sætter listen ind som kommentar.
Venter spændt på en løsning:-)
01. august 2011 - 09:17
#2
Dim antalRæk As Long, antalKol As Long
Dim farve, navn As String, antal As Byte
Dim ræk As Long
Dim antalTeamRæk As Byte
Const startRæk = 4
Public Sub opSamling()
Dim t As Long, k As Long
Application.ScreenUpdating = False
antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
antalKol = ActiveCell.SpecialCells(xlLastCell).Column
resetKom
For ræk = startRæk To antalRæk
teamRæk = beregnAntalTeamRækker(ræk)
For k = 2 To antalKol
For t = ræk To ræk + teamRæk - 1
If Cells(t, k) <> "" Then
If navn = "" Then
navn = Range("A" & t) & vbLf
Else
navn = navn & Range("A" & t) & vbLf
End If
antal = antal + 1
End If
Next t
opdaterTeam navn, antal, k, farve
resetKom
ActiveWorkbook.Sheets("Ark2").Activate
Next k
farve = ""
ræk = ræk + teamRæk - 1
Next ræk
ActiveWorkbook.Sheets("Ark1").Activate
Application.ScreenUpdating = True
End Sub
Private Sub resetKom()
navn = ""
antal = 0
End Sub
Private Function beregnAntalTeamRækker(fraRæk) As Byte
Dim ræk As Long
farve = Range("A" & fraRæk).Interior.ColorIndex
beregnAntalTeamRækker = 1
For ræk = fraRæk + 1 To antalRæk
If Range("A" & ræk).Interior.ColorIndex = farve Then
beregnAntalTeamRækker = beregnAntalTeamRækker + 1
Else
Exit For
End If
Next ræk
End Function
Private Sub opdaterTeam(navn, antal, kol, farve)
Dim ræk As Long
ActiveWorkbook.Sheets("Ark1").Activate
For ræk = startRæk To antalRæk
If ActiveSheet.Range("A" & ræk).Interior.ColorIndex = farve Then
ActiveSheet.Cells(ræk, kol).Value = antal
If antal > 0 Then
ActiveSheet.Cells(ræk, kol).AddComment Text:=navn
End If
Exit Sub
End If
Next ræk
MsgBox "Farve ikke fundet"
Stop
End Sub
