Moderatori: Anthony47, Flash30005
Sub riepzc()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=102426&p=594787#p594787
Dim I As Long, J As Long, LastI As Long, RIEP As Worksheet
Dim myMatch, myTim As Single
Set RIEP = Worksheets("RiepilogoZC") '<<< Il Nome del foglio di Riepilogo
'
RIEP.Rows("2:10000").ClearContents '*** Vedi testo
'
myTim = Timer
For I = 1 To Worksheets.Count
If Worksheets(I).Name <> RIEP.Name Then
With Worksheets(I)
LastI = .Cells(Rows.Count, "I").End(xlUp).Row
For J = 2 To LastI
myMatch = Application.Match(Trim(.Cells(J, 9).Value), RIEP.Range("A:A"), 0)
If IsError(myMatch) Then
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Trim(.Cells(J, 9).Value)
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1).Value = .Cells(J, 2).Value
Else
RIEP.Cells(myMatch, 2) = RIEP.Cells(myMatch, 2) + .Cells(J, 2).Value
End If
Next J
End With
End If
Next I
MsgBox ("Completato (" & Format(Timer - myTim, "0.00") & "sec)")
End Sub
Sub riepzc2()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=102426
Dim I As Long, J As Long, LastI As Long, RIEP As Worksheet
Dim myMatch, myTim As Single, myNSh As String
'
myNSh = "ZcRiep_" & Format(Now(), "yy-mm-dd_hh-mm")
'
If Not ShExists(myNSh) Then
Worksheets.Add after:=Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = myNSh
End If
'
Set RIEP = Sheets(myNSh)
'
RIEP.Rows("2:10000").ClearContents '*** Vedi testo
RIEP.Columns("A:A").NumberFormat = "@"
'
myTim = Timer
For I = 1 To Worksheets.Count
If Left(Worksheets(I).Name, 7) <> "ZcRiep_" Then
With Worksheets(I)
LastI = .Cells(Rows.Count, "I").End(xlUp).Row
For J = 2 To LastI
myMatch = Application.Match(Trim(.Cells(J, 9).Value), RIEP.Range("A:A"), 0)
If IsError(myMatch) Then
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Trim(.Cells(J, 9).Value)
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1).Value = .Cells(J, 2).Value
Else
RIEP.Cells(myMatch, 2) = RIEP.Cells(myMatch, 2) + .Cells(J, 2).Value
End If
Next J
End With
End If
Next I
Call CompaRieps(RIEP.Index, RIEP)
RIEP.Columns("B:C").NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-" '???
RIEP.Columns("A:A").EntireColumn.AutoFit
MsgBox ("Completato (" & Format(Timer - myTim, "0.00") & "sec)")
End Sub
Function ShExists(ByVal mySh As String) As Boolean
'
On Error Resume Next
ShExists = Len(Sheets(mySh).Name) > 0
'
End Function
Sub CompaRieps(ByVal shIndex As Long, rRiep As Worksheet)
Dim myVarr, LastM1 As Long, L As Long, myMatch
'
If shIndex < 3 Then Exit Sub
If Left(Worksheets(shIndex - 1).Name, 7) <> "ZcRiep_" Then Exit Sub
'
LastM1 = Sheets(shIndex - 1).Cells(Rows.Count, 1).End(xlUp).Row
myVarr = Sheets(shIndex - 1).Range("A1:B" & LastM1).Value
For L = (LBound(myVarr, 1) + 1) To UBound(myVarr, 1)
myMatch = Application.Match(Trim(myVarr(L, 1)), Sheets(shIndex).Range("A:A"), 0)
If myVarr(L, 1) <> "ZcMiss" Then
If IsError(myMatch) Then
rRiep.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "ZcMiss"
rRiep.Cells(Rows.Count, 1).End(xlUp).Offset(0, 3).Value = myVarr(L, 1)
rRiep.Cells(Rows.Count, 1).End(xlUp).Offset(0, 2).Value = myVarr(L, 2)
Else
If (rRiep.Cells(myMatch, 2).Value <> myVarr(L, 2)) Then
rRiep.Cells(myMatch, 3) = myVarr(L, 2)
rRiep.Cells(myMatch, 4) = myVarr(L, 1)
Else
rRiep.Cells(myMatch, 3) = 0
End If
End If
End If
Next L
End Sub
If IsError(myMatch) Then
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Trim(.Cells(J, 9).Value)
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1).Value = .Cells(J, 2).Value
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 3).Value = .Cells(J, 4).Value '+++
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 4).Value = .Cells(J, 5).Value '+++
Else
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 5).Value = .Cells(J, 7).Value '+++
Torna a Applicazioni Office Windows
Macro che scatta quando cambia dato in un altro file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 14 |
Problema con macro copia e rinomina file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
Macro che ricerca combinazioni che danno un valore Autore: kar64 |
Forum: Applicazioni Office Windows Risposte: 10 |
Macro che indica la riga prima della cella attiva Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 19 |
Visitano il forum: Nessuno e 82 ospiti