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
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