xman2000
02-07-2018, 12:06 PM
Hi partners,
please help. Thank you advanced.
i want make a Array with conditions match, differents sources columns, 2 pairs, X,y of coluns/coords (LIneA, LineB)
i want avoid more 1one Redim Preserve and make more simply array, and put Elments of 2th Pair (LIneB) into End of Array (after last element of 1th Pair LineA).
my goal is put the elements of LineB at end of Array after last element of LineA
with only 1one RedimPReserve at final of Looping, avoiding more Redim and more Loopings ForNext
Attached Workbook Excel sample file
21571
like this code (work partialy, not to end of Array and only 1th pairs
'For intSegment = 1 To RowsCountLinesABTotal
For intSegment = 1 To 13
''--------------------------------------------------------------
x1LineA = LineCoordsLineA.Cells(intSegment, 1)
Y1LineA = LineCoordsLineA.Cells(intSegment, 2)
X2LineA = LineCoordsLineA.Cells(intSegment + 1, 1)
Y2LineA = LineCoordsLineA.Cells(intSegment + 1, 2)
''--------------------------------------------------------------
x1LineB = LineCoordsLineB.Cells(intSegment, 1)
Y1LineB = LineCoordsLineB.Cells(intSegment, 2)
X2LineB = LineCoordsLineB.Cells(intSegment + 1, 1)
Y2LineB = LineCoordsLineB.Cells(intSegment + 1, 2)
''--------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
MsgBox "ArrayMatch(n)" & ArrayMatch(n) ''XMAN2000-INCLUIDO
'''''If intSegment > 0 And intSegment <= MatchCountTotalMacro Then
Dim NQuantLineA As Long
For NQuantLineA = 1 To MatchCountTotalMacro
If (x1LineA = ArrayMatch(NQuantLineA)) And (Y1LineA = ArrayMatch(NQuantLineA)) Then
CounterMatchLineA = CounterMatchLineA + 1
End If
Next
Dim NQuantLineB As Long
For NQuantLineB = 1 To MatchCountTotalMacro
If ((x1LineB = ArrayMatch(NQuantLineB)) And Y1LineB = ArrayMatch(NQuantLineB)) Then
CounterMatchLineB = CounterMatchLineB + 1
End If
Next
MsgBox "CounterMatchLineA " & CounterMatchLineA
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
ReDim Preserve ArrayX1(1 To (13 + counterAdd))
ReDim Preserve ArrayY1(1 To (13 + counterAdd))
'ReDim Preserve ArrayX1(1 To RowsCountLinesABTotal - 1)
'ReDim Preserve ArrayY1(1 To RowsCountLinesABTotal - 1)
''-------------------------------------------------------------------------------
If (x1LineA <> ArrayMatch(1) And Y1LineA <> ArrayMatch(1)) And CounterMatchLineA > 1 Then
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineA
ArrayY1(counterAdd) = Y1LineA
ElseIf (x1LineA = ArrayMatch(1) And Y1LineA = ArrayMatch(1)) Then
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineA
ArrayY1(counterAdd) = Y1LineA
' End If
ElseIf (x1LineB = ArrayMatch(1)) And (Y1LineB = ArrayMatch(1)) Then
RowAditionalLineB = 13
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineB
ArrayY1(counterAdd) = Y1LineB
ElseIf (x1LineB <> ArrayMatch(1) And Y1LineB <> ArrayMatch(1)) Then
RowAditionalLineB = 13
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineB
ArrayY1(counterAdd) = Y1LineB
End If
ReDim Preserve ArrayX1(1 To (13 + counterAdd))
ReDim Preserve ArrayY1(1 To (13 + counterAdd))
''-------------------------------------------------------------------------------
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AF").Value = ArrayX1(counterAdd)
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AG").Value = ArrayY1(counterAdd)
''-------------------------------------------------------------------------------
'counterAdd = 0
Next ''LineCoordinates
my goal is put the elements of LineB at end of Array after last element of LineA
with only 1one RedimPReserve at final of Looping, avoiding more Redim and more Loopings ForNext
ElseIf (x1LineB <> ArrayMatch(1) And Y1LineB <> ArrayMatch(1)) Then
RowAditionalLineB = 13
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineB
ArrayY1(counterAdd) = Y1LineB
end if
ReDim Preserve ArrayX1(1 To (13 + counterAdd))
ReDim Preserve ArrayY1(1 To (13 + counterAdd))
''-------------------------------------------------------------------------------
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AF").Value = ArrayX1(counterAdd)
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AG").Value = ArrayY1(counterAdd)
''-------------------------------------------------------------------------------
'counterAdd = 0
Next ''LineCoordinates
21570
edit: i am fixed some mistakes in code and sample file workbook and i hade posted new file v2 please download the new file.
the errors is in the :
x1 fixed by x1LineA
y2 fixed by Y1LineA
x2 fixed by X2LineA
y2 fixed by Y2LineA
please help. Thank you advanced.
i want make a Array with conditions match, differents sources columns, 2 pairs, X,y of coluns/coords (LIneA, LineB)
i want avoid more 1one Redim Preserve and make more simply array, and put Elments of 2th Pair (LIneB) into End of Array (after last element of 1th Pair LineA).
my goal is put the elements of LineB at end of Array after last element of LineA
with only 1one RedimPReserve at final of Looping, avoiding more Redim and more Loopings ForNext
Attached Workbook Excel sample file
21571
like this code (work partialy, not to end of Array and only 1th pairs
'For intSegment = 1 To RowsCountLinesABTotal
For intSegment = 1 To 13
''--------------------------------------------------------------
x1LineA = LineCoordsLineA.Cells(intSegment, 1)
Y1LineA = LineCoordsLineA.Cells(intSegment, 2)
X2LineA = LineCoordsLineA.Cells(intSegment + 1, 1)
Y2LineA = LineCoordsLineA.Cells(intSegment + 1, 2)
''--------------------------------------------------------------
x1LineB = LineCoordsLineB.Cells(intSegment, 1)
Y1LineB = LineCoordsLineB.Cells(intSegment, 2)
X2LineB = LineCoordsLineB.Cells(intSegment + 1, 1)
Y2LineB = LineCoordsLineB.Cells(intSegment + 1, 2)
''--------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
MsgBox "ArrayMatch(n)" & ArrayMatch(n) ''XMAN2000-INCLUIDO
'''''If intSegment > 0 And intSegment <= MatchCountTotalMacro Then
Dim NQuantLineA As Long
For NQuantLineA = 1 To MatchCountTotalMacro
If (x1LineA = ArrayMatch(NQuantLineA)) And (Y1LineA = ArrayMatch(NQuantLineA)) Then
CounterMatchLineA = CounterMatchLineA + 1
End If
Next
Dim NQuantLineB As Long
For NQuantLineB = 1 To MatchCountTotalMacro
If ((x1LineB = ArrayMatch(NQuantLineB)) And Y1LineB = ArrayMatch(NQuantLineB)) Then
CounterMatchLineB = CounterMatchLineB + 1
End If
Next
MsgBox "CounterMatchLineA " & CounterMatchLineA
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
''-------------------------------------------------------------------------------
ReDim Preserve ArrayX1(1 To (13 + counterAdd))
ReDim Preserve ArrayY1(1 To (13 + counterAdd))
'ReDim Preserve ArrayX1(1 To RowsCountLinesABTotal - 1)
'ReDim Preserve ArrayY1(1 To RowsCountLinesABTotal - 1)
''-------------------------------------------------------------------------------
If (x1LineA <> ArrayMatch(1) And Y1LineA <> ArrayMatch(1)) And CounterMatchLineA > 1 Then
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineA
ArrayY1(counterAdd) = Y1LineA
ElseIf (x1LineA = ArrayMatch(1) And Y1LineA = ArrayMatch(1)) Then
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineA
ArrayY1(counterAdd) = Y1LineA
' End If
ElseIf (x1LineB = ArrayMatch(1)) And (Y1LineB = ArrayMatch(1)) Then
RowAditionalLineB = 13
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineB
ArrayY1(counterAdd) = Y1LineB
ElseIf (x1LineB <> ArrayMatch(1) And Y1LineB <> ArrayMatch(1)) Then
RowAditionalLineB = 13
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineB
ArrayY1(counterAdd) = Y1LineB
End If
ReDim Preserve ArrayX1(1 To (13 + counterAdd))
ReDim Preserve ArrayY1(1 To (13 + counterAdd))
''-------------------------------------------------------------------------------
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AF").Value = ArrayX1(counterAdd)
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AG").Value = ArrayY1(counterAdd)
''-------------------------------------------------------------------------------
'counterAdd = 0
Next ''LineCoordinates
my goal is put the elements of LineB at end of Array after last element of LineA
with only 1one RedimPReserve at final of Looping, avoiding more Redim and more Loopings ForNext
ElseIf (x1LineB <> ArrayMatch(1) And Y1LineB <> ArrayMatch(1)) Then
RowAditionalLineB = 13
counterAdd = counterAdd + 1
ArrayX1(counterAdd) = x1LineB
ArrayY1(counterAdd) = Y1LineB
end if
ReDim Preserve ArrayX1(1 To (13 + counterAdd))
ReDim Preserve ArrayY1(1 To (13 + counterAdd))
''-------------------------------------------------------------------------------
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AF").Value = ArrayX1(counterAdd)
ActiveSheet.Cells(RowInitialAditional + counterAdd, "AG").Value = ArrayY1(counterAdd)
''-------------------------------------------------------------------------------
'counterAdd = 0
Next ''LineCoordinates
21570
edit: i am fixed some mistakes in code and sample file workbook and i hade posted new file v2 please download the new file.
the errors is in the :
x1 fixed by x1LineA
y2 fixed by Y1LineA
x2 fixed by X2LineA
y2 fixed by Y2LineA