Moderatori: Anthony47, Flash30005
Sub CopiaBccRoma()
Dim CL As Range, iRow As Integer
Dim cArr(), cInd As Long, I As Long
ReDim cArr(1 To 4, 1 To 1)
'
Sheets("Foglio1").Select
Dim Area As Range
Set Area = Sheets("Foglio1").Range("b1:b10")
For Each CL In Area 'Range("b364:b1574")
If CL.Value = "Bcc Roma" Then
'Copia la riga in cArr:
cInd = UBound(cArr, 2)
For I = 1 To 4
cArr(I, cInd) = CL.Offset(0, -2 + I).Value
Next I
ReDim Preserve cArr(1 To 4, 1 To cInd + 1)
End If
Next CL
iRow = 14
While Worksheets("Foglio2").Cells(iRow, 2).Value <> ""
iRow = iRow + 1
Wend
'Inserisce le righe in Foglio2:
Worksheets("Foglio2").Rows(iRow).Resize(cInd).Insert Shift:=xlDown 'errore 1004-Errore definito etc.etc
'Scrive il contenuto di cArr:
Worksheets("Foglio2").Cells(iRow, 2).Resize(UBound(cArr, 2), UBound(cArr)).Value = _
Application.WorksheetFunction.Transpose(cArr)
Sheets("Foglio2").Select
Set zona = Range([E14], [E14].End(xlDown))
[F13] = WorksheetFunction.Sum(zona)
End Sub
Manut.Spazi Comuni
Ordinaria
Manut. Spazi Comuni Ordinaria
If cInd >1 then
' le istruzioni
End If
If Replace(Replace(CL.Value, Chr(10), " ", , , vbTextCompare), " ", "", , , vbTextCompare) = "Manut.SpaziComuniOrdinaria" Then
If CL.Value = "Cancelleria" Then
Sheets("Foglio2").Select
Set zona = Range([E14], [E14].End(xlDown))
[F13] = WorksheetFunction.Sum(zona)
Sub CopiaBccRoma()
Dim cl As Range, iRow As Integer
Dim cArr(), cInd As Long, I As Long
ReDim cArr(1 To 4, 1 To 1)
'
Sheets("Foglio1").Select
Dim Area As Range
Set Area = Sheets("Foglio1").Range("b1:b10")
For Each cl In Area 'Range("b364:b1574")
If cl.Value = "Bcc Roma" Then
'Copia la riga in cArr:
cInd = UBound(cArr, 2)
For I = 1 To 4
cArr(I, cInd) = cl.Offset(0, -2 + I).Value
Next I
ReDim Preserve cArr(1 To 4, 1 To cInd + 1)
End If
Next cl
Sheets("Foglio2").Select
For Each cl In Sheets("Foglio2").Range("a8:a47")
If cl.Value = "Bcc Roma" Then
cl.Select
End If
Next
Range("H13") = ActiveCell.Row
iRow = ActiveCell.Row '14
While Worksheets("Foglio2").Cells(iRow, 2).Value <> ""
iRow = iRow + 1
Wend
'Inserisce le righe in Foglio2:
Worksheets("Foglio2").Rows(iRow).Resize(cInd).Insert Shift:=xlDown
'Scrive il contenuto di cArr:
Worksheets("Foglio2").Cells(iRow, 2).Resize(UBound(cArr, 2), UBound(cArr)).Value = _
Application.WorksheetFunction.Transpose(cArr)
Sheets("Foglio2").Select
Set zona = Range(ActiveCell.Offset(0, 4), ActiveCell.Offset(0, 4).End(xlDown))
ActiveCell.Offset(0, 5) = WorksheetFunction.Sum(zona)
End Sub
Sub CopiaMod(ByVal CheCosa As String, iiRow As Long)
Dim CL As Range, iRow As Integer, lSum As Single
Dim cArr(), cInd As Long, I As Long
ReDim cArr(1 To 4, 1 To 1)
'
''Sheets("Foglio1").Select
Dim Area As Range
Set Area = Range(Sheets("Foglio1").Range("b1"), Sheets("Foglio1").Range("b1").End(xlDown))
Debug.Print "Cerca " & CheCosa & " in Foglio1!" & Area.Address(0, 0)
For Each CL In Area
If UCase(CL.Value) = UCase(CheCosa) And CL.Interior.Color <> RGB(100, 255, 100) Then
'Copia la riga in cArr:
cInd = UBound(cArr, 2)
CL.Interior.Color = RGB(100, 255, 100)
For I = 1 To 4
cArr(I, cInd) = CL.Offset(0, -2 + I).Value
Next I
lSum = lSum + cArr(4, cInd)
ReDim Preserve cArr(1 To 4, 1 To cInd + 1)
End If
Next CL
If cInd > 0 Then
Debug.Print "Inserisco " & cInd & " righe sul riepilogo della voce " & CheCosa & ", SubTot: "; Format(lSum, "0.00")
iRow = iiRow
While Worksheets("Foglio2").Cells(iRow, 2).Value <> ""
iRow = iRow + 1
Wend
'Inserisce le righe in Foglio2:
Worksheets("Foglio2").Rows(iRow).Resize(cInd).Insert Shift:=xlDown
'Scrive il contenuto di cArr:
Worksheets("Foglio2").Cells(iRow, 2).Resize(UBound(cArr, 2), UBound(cArr)).Value = _
Application.WorksheetFunction.Transpose(cArr)
Sheets("Foglio2").Cells(iRow + cInd - 1, "F").Value = lSum
End If
End Sub
Sub MakeRendiconto()
Dim myVoci As Range, myC As Range, I As Long
Sheets("Foglio2").Select
Set myVoci = Range(Range("A8"), Cells(Rows.Count, 1).End(xlUp))
Debug.Print vbCrLf, ">>>> Start", myVoci.Address(0, 0)
For Each myC In myVoci
If Len(myC.Value) > 1 Then
Call CopiaMod(myC.Value, myC.Row + 1)
End If
Next myC
End Sub
......Interior.ColorIndex = xlNone
Hummm...Questo vale per i colori sul Foglio1, ma sul Foglio2 vengono ririportati gli stessi valori inseriti con la MakeRendiconto precedente generando doppioni. Almeno a me da questo risultato.
.ColorIndex <> 19
.ColorIndex = 19
Sub Restora()
Dim I As Long, LastR As Long
Dim cLine As Long, bLen As Long, Dbg As Boolean
'
Sheets("Foglio2").Select
LastR = Range("A:G").Find(What:="*", After:=Range("A1"), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Dbg = True
If Dbg Then Debug.Print ">>>>> LastR=" & LastR
For I = 8 To LastR
LastR = Range("A:G").Find(What:="*", After:=Range("A1"), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If I >= LastR Then
MsgBox ("Completato..." & vbCrLf & "Eliminare manualmente colorazione su Foglio1")
Exit Sub
End If
If Len(Cells(I, "B").Value) > 3 Then
If IsDate(Cells(I, "B")) Then
If Dbg Then Debug.Print "Inizio Blocco: " & I
cLine = I
bLen = GetLoB(cLine, 2, 1000)
If Dbg Then Debug.Print "Lungh Blocco: " & bLen
If Application.WorksheetFunction.CountA(Cells(cLine, "A").Resize(bLen, 1)) = 0 Then
Cells(cLine, "B").Resize(bLen, 5).ClearContents
' If bLen > 1 Then
If Dbg Then Debug.Print "Delete lines, n° " & bLen - 0
Cells(cLine + 1, "A").Resize(bLen - 0, 7).Delete (xlShiftUp)
' End If
Else
Cells(cLine, "B").Resize(bLen, 5).Select
If Dbg Then Debug.Print "Ambigua: " & Selection.Address(0, 0)
MsgBox ("Area selezionata non e' ripulibile automaticamente; pulire manualmente e riprovare")
Exit Sub
End If
End If
End If
Next I
End Sub
Function GetLoB(ByVal iLine, sCol As Long, Optional lMax As Long = 1000) As Long
Dim Li As Long
For Li = 1 To lMax
If Len(Cells(iLine + Li, sCol)) < 4 Then Exit For
If Not IsDate(Cells(iLine + Li, sCol).Value) Then Exit For
Next Li
GetLoB = Li
End Function
For I = 1 To 4
cArr(I, cInd) = CL.Offset(0, -2 + I).Value
Next I
For I = 1 To 4
If I = 1 Then
cArr(I, cInd) = CLng(CL.Offset(0, -2 + I).Value)
Else
cArr(I, cInd) = CL.Offset(0, -2 + I).Value
End If
Next I
Torna a Applicazioni Office Windows
Ordinare colonne sulla stessa riga se stesso contenuto Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 6 |
Macro modifica date scelta periodo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 11 |
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Supporto per sviluppo macro VBA Ordinare per data Autore: Carletto Ribolla |
Forum: Applicazioni Office Windows Risposte: 3 |
Visitano il forum: Marius44 e 12 ospiti