Assistance with excel vba-CodePudding

I have the following table that I import into excel... What I am needing to do is loop through the names (i.e. Emp1). For every instance of that employee, I need to copy columns C through F and paste in another worksheet. I would like for this to happen with every employee on the sheet.

Sub DiscrepFormReport()
    Dim cell As Range

    Range("A1").Select

    Application.ScreenUpdating = False

    'Range("A1") = Sheets("RawData").range("B2))

    For Each cell In Range("B2:B200")
        If cell <> "" Then
            Sheets("RawData").Range("C2:F2").Copy
            Sheets("DiscrepencyForm").Range("C2:F2").PasteSpecial Paste:=xlPasteValues
            ActiveCell.Offset(1, 0).Select
        End If
    Next cell

    Application.ScreenUpdating = True
End Sub

CodePudding user response：

If I'm understanding the idea, you'd want something like:

Sub Example()
    Const STARTING_ROW As Long = 2
    Dim c As Long: c = STARTING_ROW

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim cell As Range
    For Each cell In Sheets("RawData").Range("B2:B200").Cells
        If cell <> "" Then
            Sheets("DiscrepencyForm").Range("C:F").Rows(c).Value = cell.EntireRow.Columns(3).Resize(, 4).Value
            c = c   1
        End If
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

You can avoid .Copy since you're specifying that you only want values. You can just directly assign the values on the range objects, which skips the use of the windows clipboard and saves a lot of time. No need for Select or Activecell. All we need is to use the cell loop element and a second index, c, to track the destination range on the other sheet.

CodePudding user response：

Group Data Using a Dictionary of Collections

Option Explicit

Sub CreateDiscrepencyReport()
    
    ' 1. Define constants.
    
    ' s - Source (read from)
    Const sName As String = "RawData"
    Const sCriteriaRangeAddress As String = "B2:B200"
    Const sCopyColumns As String = "C:F"
    ' d - Destination (write to)
    Const dName As String = "DiscrepencyForm"
    Const dFirstCellAddress As String = "C2"
    
    ' 2. Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' 3. Write the source criteria data to an array.
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    ' Reference the source criteria range ('srg').
    Dim srg As Range: Set srg = sws.Range(sCriteriaRangeAddress)
    ' Write the values from the source criteria (one-column) range
    ' to a 2D one-based (one-column) array ('sData')...
    Dim sData() As Variant: sData = srg.Value
    ' ... and write its number of rows to a variable ('srCount').
    Dim srCount As Long: srCount = UBound(sData, 1)
    
    ' 4. Write the unique source criteria data to a dictionary.
    '    In the dictionary, its 'keys' ('sKey') will hold the unique values,
    '    while each of the corresponding 'items' ('dict(sKey)') will hold
    '    a collection of the array rows ('sr') in which the 'key' appears.
    '    Also, the number of destination rows ('drCount') will be determined.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sKey As Variant
    Dim sr As Long
    Dim drCount As Long
    
    For sr = 1 To srCount
        sKey = sData(sr, 1)
        If Not IsError(sKey) Then ' exclude error values
            If Len(CStr(sKey)) > 0 Then ' exclude blanks
                If Not dict.Exists(sKey) Then
                    ' Add the key and assign its item a new collection.
                    Set dict(sKey) = New Collection
                'Else ' key exist; collection already assigned; do nothing
                End If
                dict(sKey).Add sr ' add the row to the collection
                drCount = drCount   1 ' count the number of destination rows
            End If
        End If
    Next sr
    
    ' Validate the destination rows count (dictionary count).
    If drCount = 0 Then
        MsgBox "No valid values in column range.", vbCritical
        Exit Sub
    End If
    
    ' 5. Using the information in the dictionary, write the grouped values
    '    from the source copy range ('srg') to the destination array.
    
    ' Write the values from the source copy range
    ' to a 2D one-based array ('sData') re-using the variable.
    sData = srg.EntireRow.Columns(sCopyColumns).Value
    ' Write the number of source/destination columns to a variable.
    Dim cCount As Long: cCount = UBound(sData, 2)
    
    ' Define the destination array ('dData').
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To cCount)
    
    ' Write the values from the source array to the destination array.
    
    Dim sItem As Variant
    Dim dr As Long
    Dim c As Long
    
    For Each sKey In dict.Keys ' loop through the keys of the dictionary
        For Each sItem In dict(sKey) ' loop through the items of the collection
            dr = dr   1 ' next destination row
            For c = 1 To cCount ' loop through the source/destination columns
                dData(dr, c) = sData(sItem, c) ' write to the destination array
            Next c
        Next sItem
    Next sKey
    
    ' Free memory since the data is in the destination array.
    Erase sData
    Set dict = Nothing
    
    ' 6. Write the result to the destination worksheet.
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    ' Reference the first row of the destination range.
    With dws.Range(dFirstCellAddress).Resize(, cCount)
        ' Write the values from the destination array to the destination range.
        .Resize(dr).Value = dData
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - dr   1).Offset(dr).Clear
    End With
    
    ' Save the workbook (decide on your own).
    'wb.Save
    
    ' 7. Inform to not wonder if the code has run or not.
    MsgBox "Discrepency report created.", vbInformation
    
End Sub