1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
| Sub test6()
Dim addr1 As String
deletecom
With Sheets(1).Range(Cells(4, 4), Cells(Rows.Count, 9).End(xlUp))
For X = 1 To .Cells.Count
an = .Parent.Cells(3, .Cells(X).Column).Text
addr1 = ""
année = .Cells(3, .Cells(X).Column).Value
Sheets(3).Range("$A$3:$A" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Sheets(1).Cells(.Cells(X).Row, 3).Value
addr1 = Sheets(3).AutoFilter.Range.SpecialCells(xlCellTypeVisible).Address
If InStr(addr1, ",") > 0 Then addr1 = Split(addr1, ",")(1)
lig1 = Split(addr1, "$")(2)
If lig1 = "1:" Then lig1 = "2:"
lig2 = Split(addr1, "$")(4)
Sheets(3).Cells.AutoFilter
Select Case .Cells(X).Column
Case 4: addrb = "B" & lig1 & "B" & lig2
Case 5: addrb = "C" & lig1 & "C" & lig2
Case 6: addrb = "D" & lig1 & "D" & lig2
Case 7: addrb = "E" & lig1 & "E" & lig2
Case 8: addrb = "F" & lig1 & "F" & lig2
Case 9: addrb = "G" & lig1 & "G" & lig2
End Select
'Debug.Print addrb
With Sheets(3)
.Cells(3, 9) = .Cells(Val(lig1), 1) & " | " & an
.Cells(4, 9).Resize(.Range(addrb).Rows.Count, 1) = .Range(addrb).Value
.Columns(9).ColumnWidth = 23
.Cells(3, 9).Resize(.Range(addrb).Rows.Count + 2, 1).CopyPicture
Set suport = .ChartObjects.add(0, 0, .Range(addrb).width, .Range(addrb).height)
suport.Chart.Paste
suport.Chart.Export ThisWorkbook.Path & "\map.BMP", "BMP"
suport.Delete
.Cells(3, 9).Resize(.Range(addrb).Rows.Count, 1).ClearContents
addrdim = .Cells(3, 9).Resize(.Range(addrb).Rows.Count + 2, 1).Address
End With
.Cells(X).AddComment
'.Cells(X).Comment.Text Text:=addrB
With .Cells(X).Comment.Shape
.width = Sheets(3).Range(addrdim).width
.height = Sheets(3).Range(addrdim).height
.Fill.UserPicture ThisWorkbook.Path & "\map.BMP"
End With
Next
End With
Sheets(3).Cells(3, 9).Resize(20, 1).ClearContents
End Sub |
Partager