Macro

[ella12_12]

Bonjour à tous,

J'aurais besoin de vos lumière afin de pouvoir résoudre un problème dans une macro que j'ai faite.
Voici le code :

Sub AnalyzePatch()
'
' AnalyzePatch Macro
' Macro enregistré 24/11/07 par Maëlle
'
' Touche de raccourci du clavier: Ctrl+Maj+A

'Define Variables
Dim Mysheet As Object
Dim Plot_Cell As Object

Const Plot_Cell As String = "C10:L19"
Const Raw_Range As String = "C25:L34"

Dim Patch_Count As Integer
Dim New_Neighbor_Found As Boolean
Dim No_Remaining_Forested_Cells As Boolean
Dim No_New_Neighboirs As Boolean
Dim First_Cell_This_Patch As Boolean
Dim i As Integer, EdgeCount As Integer, NeighborCount As Integer, _
CoreCount As Integer

Set Mysheet = Worksheets("Sheet1")

'Clear out old edge and core count data
With Mysheet
.Range("B100", .Range("B100").End(xlDown)).EntireRow.Delete
End With

'Copy Raw Data into analysis range
Mysheet.Range(Raw_Range).Copy
Mysheet.Range(Plot_Range).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

'Perform Nested Patch Loops
'Starting Analysis Assumptions
Patch_Count = 0
No_Remaining_Forested_Cells = False

'Outer Loop - Repeats once per patch
Do Until No_Remaining_Forested_Cells = True

'Reset variables for new patch search
Patch_Count = Patch_Count + 1
No_New_Neighbors = False

'Inner Loop - Repeats until no more forested neighbors are
'found adjacent to the current patch.
Do Until No_New_Neighbors = True

New_Neighbor_Found = False

'Performs one complete pass through the grid looking
'for forested cells
For Each Plot_Cell In Range(Plot_Range)

'Identifies the first forested cell in a patch and
'forces all future searches for this patch to be
'neighbor comparisons
If UCase(Plot_Cell.Value) = "F" And _
First_Cell_This_Patch = False Then
Plot_Cell.Value = Patch_Count
First_Cell_This_Patch = True
New_Neighbor_Found = True
End If

'Indentifies and marks neighbor cells of the current patch
If UCase(Plot_Cell.Value) = "F" And _
(Plot_Cell.Offset(-1, 0).Value = Patch_Count Or _
Plot_Cell.Offset(0, 1).Value = Patch_Count Or _
Plot_Cell.Offset(1, 0).Value = Patch_Count Or _
Plo_Cell.Offset(0, -1).Value = Patch_Count) Then
Plot_Cell.Value = Patch_Count
New_Neighbor_Found = True
End If

Next Plot_Cell

If New_Neighbor_Found = False Then No_New_Neighbors = True

Loop

If First_Cell_This_Patch = False Then
No_Remaining_Forested_Cells = True
End If

Loop

'Start Edge and Core Count Analysis
With Mysheet.Range("C99")

For i = 1 To Patch_Count - 1

.Offset(i, 0).Value = "Patch " & i
'Count Patch Edge sections by subtracting
'patch neighbors from 4

EdgeCount = 0
CoreCount = 0
For Each Plot_Cell In Range(Plot_Range)
If Plot_Cell.Value = i Then
NeigborCount = -1 * ((Plot_Cell.Offset(-1, 0).Value = i) _
+ (Plot_Cell.Offset(0, 1).Value = i) _
+ (Plot_Cell.Offset(1, 0).Value = i) _
+ (Plot_Cell.Offset(0, -1).Value = i))
EdgeCount = EdgeCount + (4 - NeighborCount)
End If

'Count Core cells by tallying cells with 4 neighbors
If Plot_Cell.Value = i And NeighborCount = 4 Then
CoreCount = CoreCount + 1
End If

Next Plot_Cell
.Offset(i, -1).Value = EdgeCount
.Offset(i, 1).Value = CoreCount

Next i

End With

Calculate

'Reset cursor to upper left corner
Mysheet.Range("C25").Select

Set Mysheet = Nothing

End Sub
cette macro devrait en fait mettre des chiffres dans certaine cellules 1, 2, 3, .... en fait j'ai un autre tableau ou il y a un format conditionnel. Merci à tous pour les bons soins que vous porterez à mon problème
Ella

 

[Banzai64]

Re : Macro

Bonjour

Sans connaitre le prog cela ne vas pas etre facile de voir le résultat

sinon quelques erreurs dans ton code

' ****** Double déclaration
'Dim Plot_Cell As Object
'Const Plot_Cell As String = "C10:L19"

' ****** Non défini
'Plot_Range  [COLOR="red"]et non initialisé[/COLOR]
'No_New_Neighbors
'NeigborCount
'
' Mysheet.Range([COLOR="red"]Plot_Range[/COLOR]).PasteSpecial Paste:=xlValues, _
                            Operation:=xlNone, SkipBlanks:=False, Transpose:=False


' ***** Erreur de variable
'Plo_Cell
'Indentifies and marks neighbor cells of the current patch
'If UCase(Plot_Cell.Value) = "F" And (Plot_Cell.Offset(-1, 0).Value = Patch_Count Or _
                                      Plot_Cell.Offset(0, 1).Value = Patch_Count Or _
                                      Plot_Cell.Offset(1, 0).Value = Patch_Count Or _
                                      [COLOR="Red"]Plo_Cell[/COLOR].Offset(0, -1).Value = Patch_Count) Then '

Si toujours problèmes fournis un p'tit bout de fichier dans les conditions habituelles

 

[ella12_12]

Re : Macro

j'ai toujours des problèmes malgré le fait que j'ai fais une ou deux corrections.
Mais bon, je ne m'y connais pas trop non plus.... (sourire)

Ce qu'il faudrait obtenir est le 3ème tableau qui se trouve sur le document précedent

Merci beauoup pour votre aide

E

 

[Banzai64]

Re : Macro

Re
C'est pas mon jour
Je ne peux pas lire ton fichier car il est au format 2007 (beuurk)
Si tu peux le mettre au format xls

 

[ella12_12]

Re : Macro

voici le fichier au format 2003

Merci d'avance pour tout
E

 

[Banzai64]

Re : Macro

Bonjour

Un essai
Je ne trouve pas exactement ce que tu voulais mais vérifies quand même

 

[ella12_12]

Re : Macro

Un tout grand merci à vous. C'est exactement ce que je voulais

Merci, Merci, Merci

E