Moderatori: Anthony47, Flash30005
Sub riepzc2()
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("C:C").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("C:C"), 0)
If IsError(myMatch) Then
RIEP.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Value = Trim(.Cells(J, 9).Value)
RIEP.Cells(Rows.Count, 3).End(xlUp).Offset(0, -1).Value = .Cells(J, 2).Value
RIEP.Cells(Rows.Count, 3).End(xlUp).Offset(0, 1).Value = .Cells(J, 4).Value
RIEP.Cells(Rows.Count, 3).End(xlUp).Offset(0, 2).Value = .Cells(J, 5).Value
RIEP.Cells(Rows.Count, 3).End(xlUp).Offset(0, 3).Value = .Cells(J, 7).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("C:C").EntireColumn.AutoFit
MsgBox ("Completato (" & Format(Timer - myTim, "0.00") & "sec)")
renum
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("C:C"), 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
Private Sub renum()
Dim x, C2
'
x = 0
For Each C2 In Range("C:C")
If C2 <> "" Then
C2.Offset(0, -2).Value = x
'Else
'Hl.Offset(0, -7).Value = ""
End If
x = x + 1
Next
End Sub
MsgBox ("Completato (" & Format(Timer - myTim, "0.00") & "sec)")
renum
renum
MsgBox ("Completato (" & Format(Timer - myTim, "0.00") & "sec)")
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
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 '+++
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 5).Value = .Cells(J, 7).Value '+++
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 8).Value = Worksheets(I).Name '^^^^^
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 7).Value = .Cells(J, 2).Value '^^^^^
Else
RIEP.Cells(myMatch, 2) = RIEP.Cells(myMatch, 2) + .Cells(J, 2).Value
nextc = RIEP.Cells(myMatch, Columns.Count).End(xlToLeft).Offset(0, 1).Column '^^^^^
RIEP.Cells(myMatch, nextc + 1).Value = Worksheets(I).Name '^^^^^
RIEP.Cells(myMatch, nextc).Value = .Cells(J, 2).Value '^^^^^
End If
Next J
Sub riepzc2()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=102426
'--rivista1 per importare anche Descriz, Part Numb e Note (la chiave e' il CodiceAzienda)
'--rivista2 per inserire i Fogli di appartenenza del codice
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
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 '+++
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 5).Value = .Cells(J, 7).Value '+++
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 8).Value = Worksheets(I).Name '^^^^^
RIEP.Cells(Rows.Count, 1).End(xlUp).Offset(0, 7).Value = .Cells(J, 2).Value '^^^^^
Else
RIEP.Cells(myMatch, 2) = RIEP.Cells(myMatch, 2) + .Cells(J, 2).Value
nextc = RIEP.Cells(myMatch, Columns.Count).End(xlToLeft).Offset(0, 1).Column '^^^^^
RIEP.Cells(myMatch, nextc + 1).Value = Worksheets(I).Name '^^^^^
RIEP.Cells(myMatch, nextc).Value = .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
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 78 ospiti