Dear Senior member
I found this vba running code in our group but I need to loop value in multiple sheet then show result in new sheet. But code below loop only one sheet. Please help to guide add some code (loop multiple sheet).
Sub CopyPartsForReview()
Dim wb As Workbook
Dim shtMaster As Worksheet, shtReview As Worksheet, shtOut As Worksheet
Dim rowLastMstr As Long, rowLastRev As Long
Dim rngMstr As Range, rngRev As Range
Dim arrMstr As Variant, arrRev As Variant, arrOut As Variant
Dim dictRev As Object, dictKey As String
Dim i As Long, j As Long, rowOut As Long
Set wb = ActiveWorkbook
Set shtMaster = wb.Worksheets("Master")
Set shtReview = wb.Worksheets("Review")
With shtMaster
rowLastMstr = .Range("C" & Rows.Count).End(xlUp).Row
Set rngMstr = .Range("A1:O" & rowLastMstr)
arrMstr = rngMstr.Value2
End With
ReDim arrOut(1 To UBound(arrMstr, 1), 1 To UBound(arrMstr, 2))
With shtReview
rowLastRev = .Range("A" & Rows.Count).End(xlUp).Row
Set rngRev = .Range("A2:A" & rowLastRev)
arrRev = rngRev.Value2
End With
Set dictRev = CreateObject("Scripting.dictionary")
dictRev.CompareMode = vbTextCompare
' Review Parts into Dictionary
For i = 1 To UBound(arrRev)
dictKey = arrRev(i, 1)
If Not dictRev.exists(dictKey) Then
dictRev(dictKey) = i
End If
Next i
For i = 2 To UBound(arrMstr)
dictKey = arrMstr(i, 3)
If dictRev.exists(dictKey) Then
rowOut = rowOut + 1
For j = 1 To UBound(arrMstr, 2)
arrOut(rowOut, j) = arrMstr(i, j)
Next j
End If
Next i
If rowOut > 0 Then
With wb
Set shtOut = .Sheets.Add(After:=.Worksheets(.Worksheets.Count))
End With
With shtOut
rngMstr.Rows(1).Copy Destination:=.Range("A1")
.Range("A2").Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
.Columns("A").Resize(, UBound(arrOut, 2)).AutoFit
End With
End If
End Sub
I found this vba running code in our group but I need to loop value in multiple sheet then show result in new sheet. But code below loop only one sheet. Please help to guide add some code (loop multiple sheet).
Sub CopyPartsForReview()
Dim wb As Workbook
Dim shtMaster As Worksheet, shtReview As Worksheet, shtOut As Worksheet
Dim rowLastMstr As Long, rowLastRev As Long
Dim rngMstr As Range, rngRev As Range
Dim arrMstr As Variant, arrRev As Variant, arrOut As Variant
Dim dictRev As Object, dictKey As String
Dim i As Long, j As Long, rowOut As Long
Set wb = ActiveWorkbook
Set shtMaster = wb.Worksheets("Master")
Set shtReview = wb.Worksheets("Review")
With shtMaster
rowLastMstr = .Range("C" & Rows.Count).End(xlUp).Row
Set rngMstr = .Range("A1:O" & rowLastMstr)
arrMstr = rngMstr.Value2
End With
ReDim arrOut(1 To UBound(arrMstr, 1), 1 To UBound(arrMstr, 2))
With shtReview
rowLastRev = .Range("A" & Rows.Count).End(xlUp).Row
Set rngRev = .Range("A2:A" & rowLastRev)
arrRev = rngRev.Value2
End With
Set dictRev = CreateObject("Scripting.dictionary")
dictRev.CompareMode = vbTextCompare
' Review Parts into Dictionary
For i = 1 To UBound(arrRev)
dictKey = arrRev(i, 1)
If Not dictRev.exists(dictKey) Then
dictRev(dictKey) = i
End If
Next i
For i = 2 To UBound(arrMstr)
dictKey = arrMstr(i, 3)
If dictRev.exists(dictKey) Then
rowOut = rowOut + 1
For j = 1 To UBound(arrMstr, 2)
arrOut(rowOut, j) = arrMstr(i, j)
Next j
End If
Next i
If rowOut > 0 Then
With wb
Set shtOut = .Sheets.Add(After:=.Worksheets(.Worksheets.Count))
End With
With shtOut
rngMstr.Rows(1).Copy Destination:=.Range("A1")
.Range("A2").Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
.Columns("A").Resize(, UBound(arrOut, 2)).AutoFit
End With
End If
End Sub
