Sub CopiaMaria() Dim i As Long Dim ur As Long Dim lr As Long Dim nVolte As Long Dim rng As Range Dim cel As Range ur = Sheets("Foglio1").Cells(Rows.Count, 1).End(xlUp).Row Set rng = Sheets("Foglio1").Range("A2:A" & ur) Application.ScreenUpdating = False For Each cel In rng nVolte = Application.WorksheetFunction.CountIf(Sheets("Foglio2").Range("a2:a51"), cel.Value) For i = 1 To nVolte + 1 lr = Sheets("Risultato").Cells(Rows.Count, 1).End(xlUp).Row Sheets("Foglio1").Activate Range(Cells(cel.Row, "A"), Cells(cel.Row, "H")).Copy Destination:=Sheets("Risultato").Cells(lr + 1, "A") Next i Next cel Sheets("prova").Activate Application.ScreenUpdating = True End Sub
marym.87, 16/10/2018 14.32:Non c'è un modo di dire copia della stessa riga per n volte dalla colonna A alla colonna G e prendi colonna H dal foglio 2?
Sub duplicaRighe() Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet Set Sh1 = Worksheets("Foglio1") Set Sh2 = Worksheets("Foglio2") Set Sh3 = Worksheets("Risultato") Ur1 = Sh1.Range("A" & Rows.Count).End(xlUp).Row ur2 = Sh2.Range("A" & Rows.Count).End(xlUp).Row Sh3.Range("A2:H" & Rows.Count).ClearContents r1 = 2 r2 = 2 r3 = 2 For j1 = r1 To Ur1 codice = Sh1.Cells(j1, 1) Sh1.Range("A" & j1 & ":H" & j1).Copy Sh3.Range("A" & r3) r3 = r3 + 1 For j2 = r2 To ur2 If Sh2.Cells(j2, 1) = codice Then Sh1.Range("A" & j1 & ":G" & j1).Copy Sh3.Range("A" & r3) Sh3.Cells(r3, 8) = Sh2.Cells(j2, 7) r3 = r3 + 1 End If Next j2 Next j1 End Sub
Option Explicit Sub Test_pg() Application.ScreenUpdating = False Dim NrP As Long, NR1 As Long, Nr2 As Long, x As Long, y As Long, k As Long Dim FgP As Worksheet, Fg1 As Worksheet, Fg2 As Worksheet Set FgP = Sheets("Risultato") Set Fg1 = Sheets("Foglio1") Set Fg2 = Sheets("Foglio2") FgP.Activate NrP = Range("A" & Rows.Count).End(xlUp).Row If NrP < 2 Then NrP = 2 Range(Cells(2, 1), Cells(NrP, 8)).ClearContents Range(Cells(2, 1), Cells(NrP, 8)).Interior.Pattern = xlNone k = 2 Fg1.Activate NR1 = Range("A" & Rows.Count).End(xlUp).Row Fg2.Activate Nr2 = Range("A" & Rows.Count).End(xlUp).Row For x = 2 To NR1 Fg1.Activate Fg1.Range(Cells(x, 1), Cells(x, 8)).Copy FgP.Activate Cells(k, 1).PasteSpecial Paste:=xlValues Range(Cells(k, 1), Cells(k, 8)).Interior.Color = 65535 For y = 2 To Nr2 If Fg2.Cells(y, 1) = Cells(y, 1) Then k = k + 1 Range(Cells(x, 1), Cells(x, 7)).Copy Cells(k, 1).PasteSpecial Paste:=xlValues Fg2.Cells(y, 7).Copy Cells(k, 8).PasteSpecial Paste:=xlValues End If Next y k = k + 1 Next x Set FgP = Nothing Set Fg1 = Nothing Set Fg2 = Nothing Application.ScreenUpdating = True Cells(2, 1).Select End Sub
Quando il gioco si fa duro i duri cominciano a giocare
If Fg2.Cells(y, 1) = Cells(y, 1) Then
If Fg2.Cells(y, 1) = Cells(x, 1) Then