
Grazie
R
PS Dall'amico Alfredo stessa richiesta, ma la soluzione è rimasta nella penna, anzi nelle dita, di Terio
Moderatori: Anthony47, Flash30005
Sub Allinea()
Dim bsArr, bcArr(), aInd
Dim LaR As Long, Gr1W As Long, Gr2W As Long
Dim I As Long, myMatch, JJ As Long, DummInd As Long, ExtraL As Long
'
Gr1W = Range("A1").CurrentRegion.Columns.Count
Gr2W = Cells(1, Gr1W + 2).CurrentRegion.Columns.Count
'
'End gruppo B:
LaR = Cells(1, Gr1W + 2).Resize(10000, Gr2W).Find(What:="*", After:=Cells(1, Gr1W + 2), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'
aInd = Application.WorksheetFunction.Index(Range("A1").CurrentRegion, 0, 2) 'Indice gruppo A
bsArr = Cells(1, Gr1W + 2).Resize(LaR, Gr2W).Value 'Gruppo B
ReDim bcArr(1 To UBound(bsArr) * 2, 1 To UBound(bsArr, 2)) 'Gruppo B pulito
DummInd = 765765000
For I = 1 To UBound(aInd)
'fill righe vuote
If Len(aInd(I, 1)) = 0 Then
aInd(I, 1) = DummInd
DummInd = DummInd + 1
End If
Next I
DummInd = 765765000
ExtraL = 0
For I = 1 To UBound(bsArr)
'Cerca e allinea:
If Len(bsArr(I, 1)) > 0 Then 'Pieno /Vuoto
If I = 1 Then 'Copia Headers
myMatch = 1
Else
myMatch = Application.Match(bsArr(I, 1), aInd, False) 'Posiz in AIND
End If
If IsError(myMatch) Then 'Manca, cerca DummInd
myMatch = Application.Match(DummInd, aInd, False) 'Posiz con DummInd
If IsError(myMatch) Then 'Manca, aggiungi
ExtraL = ExtraL + 1
myMatch = UBound(aInd) + ExtraL
For JJ = 1 To UBound(bsArr, 2) 'Copia in posizione
bcArr(myMatch, JJ) = bsArr(I, JJ)
Next JJ
Else 'Trovato con DummInd
For JJ = 1 To UBound(bsArr, 2) 'Copia in posizione
bcArr(myMatch, JJ) = bsArr(I, JJ)
Next JJ
DummInd = DummInd + 1
End If
Else 'Trovato in AInd
For JJ = 1 To UBound(bsArr, 2) 'Copia in posizione
bcArr(myMatch, JJ) = bsArr(I, JJ)
Next JJ
End If
End If
Next I
'Riscrive Area B:
Cells(1, Gr1W + 2).Resize(UBound(bcArr), UBound(bcArr, 2)).Value = bcArr
End Sub
Sub Allinea()
Dim bsArr, bcArr(), aInd
Dim LaR As Long, Gr1W As Long, Gr2W As Long
Dim I As Long, myMatch, JJ As Long, DummInd As Long, ExtraL As Long
'
'End Gruppo A:
LaR = Cells(Rows.Count, 1).End(xlUp).Row
aInd = Range("A1").Resize(LaR, 1).Value 'Indice gruppo A
Gr1W = Range("A1").CurrentRegion.Columns.Count
Gr2W = Cells(1, Gr1W + 2).CurrentRegion.Columns.Count
'
'End gruppo B:
LaR = Cells(1, Gr1W + 2).Resize(10000, Gr2W).Find(What:="*", After:=Cells(1, Gr1W + 2), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'
bsArr = Cells(1, Gr1W + 2).Resize(LaR, Gr2W).Value 'Gruppo B
ReDim bcArr(1 To UBound(bsArr) * 2, 1 To UBound(bsArr, 2)) 'Gruppo B pulito
DummInd = 765765000
For I = 1 To UBound(aInd)
'fill righe vuote
If Len(aInd(I, 1)) = 0 Then
aInd(I, 1) = DummInd
DummInd = DummInd + 1
End If
Next I
DummInd = 765765000
ExtraL = 0
For I = 1 To UBound(bsArr)
'Cerca e allinea:
If Len(bsArr(I, 1)) > 0 Then 'Pieno /Vuoto
If I < 3 Then 'Copia Headers
myMatch = I
Else
myMatch = Application.Match(bsArr(I, 1), aInd, False) 'Posiz in AIND
End If
If IsError(myMatch) Then 'Manca, cerca DummInd
myMatch = Application.Match(DummInd, aInd, False) 'Posiz con DummInd
If IsError(myMatch) Then 'Manca, aggiungi
ExtraL = ExtraL + 1
myMatch = UBound(aInd) + ExtraL
For JJ = 1 To UBound(bsArr, 2) 'Copia in posizione
bcArr(myMatch, JJ) = bsArr(I, JJ)
Next JJ
Else 'Trovato con DummInd
For JJ = 1 To UBound(bsArr, 2) 'Copia in posizione
bcArr(myMatch, JJ) = bsArr(I, JJ)
Next JJ
DummInd = DummInd + 1
End If
Else 'Trovato in AInd
For JJ = 1 To UBound(bsArr, 2) 'Copia in posizione
bcArr(myMatch, JJ) = bsArr(I, JJ)
Next JJ
End If
End If
Next I
'Riscrive Area B:
Cells(1, Gr1W + 2).Resize(UBound(bcArr), UBound(bcArr, 2)).Value = bcArr
End Sub
Torna a Applicazioni Office Windows
Supporto per sviluppo macro VBA Ordinare per data Autore: Carletto Ribolla |
Forum: Applicazioni Office Windows Risposte: 3 |
Stabilire righe e colonne da mostrare a schermo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 10 |
adattare il contenuto alla pagina Autore: trittico69 |
Forum: Applicazioni Office Windows Risposte: 12 |
Visitano il forum: Nessuno e 31 ospiti