Moderatori: Anthony47, Flash30005
Sub PulisciPg()
Set Ws1 = Worksheets("CFS2012BANCADATI") '<<< cambia il nome del foglio origine
Set Ws2 = Worksheets("Matrice")
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
For RR1 = UR1 To 1 Step -1
If Left(Ws1.Range("A" & RR1).Value, 4) = "pag." Then
Rows(RR1 & ":" & RR1 + 2).Delete Shift:=xlUp
End If
If Ws1.Range("A" & RR1).Value = "" Then
Rows(RR1).Delete Shift:=xlUp
End If
Next RR1
End Sub
Sub CreaMatrice()
Set Ws1 = Worksheets("CFS2012BANCADATI")
Set Ws2 = Worksheets("Matrice")
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual
Ws2.Cells.ClearContents
RigaIni = 1
Ws1.Select
MValore = 0
Inizio:
For RR1 = RigaIni To UR1
If IsNumeric(Left(Ws1.Range("A" & RR1).Value, 4)) Then
ValoreD = Val(Left(Ws1.Range("A" & RR1).Value, 4))
If MValore <> 0 And MValore < ValoreD Then GoTo SaltaRRR
For RRA = RR1 + 1 To RR1 + 15
If (Len(Trim(Range("A" & RRA).Value)) = 1 And Trim(Range("A" & RRA).Value) = "A") Then
RigaD = RRA - 1
Col = 1
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
Domanda = ""
For RRD = RigaIni To RigaD
Domanda = Domanda & " " & Ws1.Range("A" & RRD)
Next RRD
Domanda = Trim(Domanda)
Ws2.Range("A" & UR2).Value = Domanda
Exit For
End If
Next RRA
For RRB = RigaD + 1 To RigaD + 6
If Trim(Range("A" & RRB).Value) = "" Then GoTo SaltaRRB
If (Len(Trim(Range("A" & RRB).Value)) = 1 And Trim(Range("A" & RRB).Value) = "B") Then
RigaRA = RRB - 1
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
RispA = ""
For RRA = RigaD + 1 To RigaRA
RispA = RispA & " " & Ws1.Range("A" & RRA)
Next RRA
RispA = Trim(RispA)
Ws2.Range("B" & UR2).Value = RispA
Exit For
End If
SaltaRRB:
Next RRB
For RRC = RigaRA + 1 To RigaRA + 6
If (Len(Trim(Range("A" & RRC).Value)) = 1 And Trim(Range("A" & RRC).Value) = "C") Then
RigaRB = RRC - 1
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
RispB = ""
For RRA = RigaRA + 1 To RigaRB
RispB = RispB & " " & Ws1.Range("A" & RRA)
Next RRA
RispB = Trim(RispB)
Ws2.Range("B" & UR2).Value = RispB
Exit For
End If
Next RRC
For RRU = RigaRB + 1 To RigaRB + 6
If IsNumeric(Left(Ws1.Range("A" & RRU).Value, 4)) And Val(Left(Ws1.Range("A" & RRU).Value, 4)) = ValoreD + 1 Then
MValore = ValoreD + 1
RigaRC = RRU - 1
RigaIni = RRU
Exit For
End If
Next RRU
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
RispC = ""
For RRA = RigaRB + 1 To RigaRC
RispC = RispC & " " & Ws1.Range("A" & RRA)
Next RRA
RispC = Trim(RispC)
Ws2.Range("B" & UR2).Value = RispC
GoTo Inizio
SaltaRRR:
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub CreaMatrice()
Set ws1 = Worksheets("CFS2012BANCADATI")
Set Ws2 = Worksheets("Matrice")
UR1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual
Ws2.Cells.ClearContents
RigaIni = 1
ws1.Select
MValore = 0
Inizio:
For RR1 = RigaIni To UR1
'If RR1 >= 4587 Then MsgBox RR1
If IsNumeric(Left(ws1.Range("A" & RR1).Value, 4)) Then
ValoreD = Val(Left(ws1.Range("A" & RR1).Value, 4))
If MValore > 0 And ValoreD = MemV Then
MsgBox "Anomalia nella Domanda " & MValore + 1 & " (forse mancante), controllare...", vbCritical
GoTo esci:
End If
MemV = ValoreD
If MValore <> 0 And MValore < ValoreD Then GoTo SaltaRRR
For RRA = RR1 + 1 To RR1 + 15
If (Len(Trim(ws1.Range("A" & RRA).Value)) = 1 And Trim(ws1.Range("A" & RRA).Value) = "A") Then
RigaD = RRA - 1
Col = 1
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
Domanda = ""
For RRD = RigaIni To RigaD
Domanda = Domanda & " " & ws1.Range("A" & RRD)
Next RRD
Domanda = Trim(Domanda)
Ws2.Range("A" & UR2).Value = Domanda
Exit For
End If
Next RRA
For RRB = RigaD + 1 To RigaD + 6
If Trim(ws1.Range("A" & RRB).Value) = "" Then GoTo SaltaRRB
If (Len(Trim(ws1.Range("A" & RRB).Value)) = 1 And Trim(ws1.Range("A" & RRB).Value) = "B") Then
RigaRA = RRB - 1
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
RispA = ""
For RRA = RigaD + 1 To RigaRA
RispA = RispA & " " & ws1.Range("A" & RRA)
Next RRA
RispA = Trim(RispA)
Ws2.Range("B" & UR2).Value = RispA
Exit For
End If
SaltaRRB:
Next RRB
For RRC = RigaRA + 1 To RigaRA + 6
If (Len(Trim(ws1.Range("A" & RRC).Value)) = 1 And Trim(ws1.Range("A" & RRC).Value) = "C") Then
RigaRB = RRC - 1
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
RispB = ""
For RRA = RigaRA + 1 To RigaRB
RispB = RispB & " " & ws1.Range("A" & RRA)
Next RRA
RispB = Trim(RispB)
Ws2.Range("B" & UR2).Value = RispB
Exit For
End If
Next RRC
For RRU = RigaRB + 1 To RigaRB + 6
If IsNumeric(Left(ws1.Range("A" & RRU).Value, 4)) And Val(Left(ws1.Range("A" & RRU).Value, 4)) = ValoreD + 1 Then
MValore = ValoreD + 1
RigaRC = RRU - 1
RigaIni = RRU
Exit For
End If
Next RRU
UR2 = Ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
RispC = ""
For RRA = RigaRB + 1 To RigaRC
RispC = RispC & " " & ws1.Range("A" & RRA)
Next RRA
RispC = Trim(RispC)
Ws2.Range("B" & UR2).Value = RispC
GoTo Inizio
SaltaRRR:
End If
Next RR1
esci:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Torna a Applicazioni Office Windows
posizionamento casuale di risposte Autore: robertogiuseppe |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 15 ospiti