Salve se possibile un ulteriore aiuto per winc....
se riesco ad allegare il file spieghero' cosa vorrei
sempre che mi sia aperta la porta
Moderatori: Anthony47, Flash30005
Sub MahBoh()
Dim StarTab As Range, dBg As Boolean
Dim LaCol As Long, LaRow As Long
Dim cNum As Long, cCnt As Long
'
Set StarTab = Range("L1")
LaCol = StarTab.Offset(0, 1000).End(xlToLeft).Column
row0 = StarTab.Resize(15000, LaCol - StarTab.Cells(1, 1).Column + 1).Address
LaRow = 1 + Evaluate("MAX((LEN(" & row0 & ")>0)*(ROW(" & row0 & ")))")
dBg = True
For i = 1 To LaCol
cNum = StarTab.Cells(1, i)
If cNum > 0 Then
For j = 2 To LaRow
If StarTab.Cells(j, i) = cNum Then
For k = 1 To 6
''Debug.Print cNum, StarTab.Cells(j + k, i).Resize(1, 5).Address(0, 0), Application.WorksheetFunction.TextJoin(",", False, StarTab.Cells(j + k, i).Resize(1, 5))
If Application.WorksheetFunction.Count(StarTab.Cells(j + k, i).Resize(1, 5)) = 2 Then
If Application.WorksheetFunction.CountIf(StarTab.Cells(j + k, i).Resize(1, 5), cNum) > 0 Then
If dBg Then Debug.Print cNum, StarTab.Cells(j + k, i).Resize(1, 5).Address(0, 0), Application.WorksheetFunction.TextJoin(",", False, StarTab.Cells(j + k, i).Resize(1, 5))
cCnt = cCnt + 1
End If
End If
Next k
''Debug.Print
End If
Next j
DoEvents
StarTab.Cells(LaRow + 1, i) = cCnt
cCnt = 0
End If
Next i
MsgBox ("Completato; risultati su riga " & LaRow + 1)
End Sub
Dim Row0, I As Long, J As Long, K As Long
Set StarTab = Range("L1") '<<< La prima cella del tabellone (aggiunto commento)
Di dubbi ne avrei, ma il principale è "a che serve?"se qualche dubbio fammelo presente ...
For K = 1 To 6
''Debug.Print cNum, StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5).Address(0, 0), Application.WorksheetFunction.TextJoin(",", False, StarTab.Cells(J + K, I).Resize(1, 5))
If Application.WorksheetFunction.Count(StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5)) = 2 Then
If Application.WorksheetFunction.CountIf(StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5), cNum) > 0 Then
If dBg Then Debug.Print cNum, StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5).Address(0, 0), Application.WorksheetFunction.TextJoin(",", False, StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5))
cCnt = cCnt + 1
fLg = True
End If
End If
Next K
''Debug.Print
End If
If fLg = True Then '<<< Per non conteggiare 2 volte lo stesso elemento
J = J + 5
fLg = False
End If
Next J
Sub MahBoh()
Dim fLg As Boolean '<<< Nuova
51 L202:P202 51,,45,,
51 L549:P549 51,,,4,
51 L1500:P1500 51,,,,72
51 L1504:P1504 51,,,4,
...
...
Sub MahBoh()
Dim fLg As Boolean, Span As Long, SoloCoppia As Boolean ' Modificata
Dim Row0, I As Long, J As Long, K As Long
Dim StarTab As Range, dBg As Boolean
Dim LaCol As Long, LaRow As Long
Dim cNum As Long, cCnt As Long
'
Set StarTab = Range("L1") '<<< La prima cella del tabellone
Span = 6 '<<< Per quante righe cercare
SoloCoppia = True '<<< True = basta che ci sia la coppia
'
LaCol = StarTab.Offset(0, 1000).End(xlToLeft).Column
Row0 = StarTab.Resize(15000, LaCol - StarTab.Cells(1, 1).Column + 1).Address
LaRow = 1 + Evaluate("MAX((LEN(" & Row0 & ")>0)*(ROW(" & Row0 & ")))")
dBg = True
For I = 1 To LaCol
cNum = StarTab.Cells(1, I)
If cNum > 0 Then
For J = 2 To LaRow
If StarTab.Cells(J, I) = cNum Then
For K = 1 To Span
''Debug.Print cNum, StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5).Address(0, 0), Application.WorksheetFunction.TextJoin(",", False, StarTab.Cells(J + K, I).Resize(1, 5))
If Application.WorksheetFunction.Count(StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5)) = 2 Then
If Application.WorksheetFunction.CountIf(StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5), cNum) > 0 Or SoloCoppia Then
If dBg Then Debug.Print cNum, J, StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5).Address(0, 0), Application.WorksheetFunction.TextJoin(",", False, StarTab.Cells(J + K, Int(I / 7) * 7 + 1).Resize(1, 5))
cCnt = cCnt + 1
fLg = True
End If
End If
Next K
''Debug.Print
End If
If fLg = True Then 'Per non conteggiare 2 volte lo stesso elemento
J = J + Span - 1
fLg = False
End If
Next J
DoEvents
StarTab.Cells(LaRow + 1, I) = cCnt
cCnt = 0
End If
Next I
MsgBox ("Completato; risultati su riga " & LaRow + 1)
End Sub
Dim bCell As String
bCell = StarTab.Offset(-StarTab.Row + 1, 0).Address
On Error Resume Next
LaRow = Range(bCell).Resize(15000, LaCol).Find(What:="*", After:=Range(bCell), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
On Error GoTo 0
Torna a Applicazioni Office Windows
Strano problema su due notebook asus quasi identici Autore: cloudstr1234 |
Forum: Assistenza Hardware Risposte: 0 |
Visitano il forum: Nessuno e 17 ospiti