Question

我有一个合并器工具，可以合并来自不同工作表的数据。它最多可以处理一百万行。但是，当我单击该按钮以检查重复项时，出现错误消息“没有足够的内存来执行此操作”。我注意到只有在运行此宏时才会发生此错误。请原谅我的不良实践代码，因为这是我的编程新手，这是当前可以正常使用的代码。无论如何，我仍然可以在维护功能的同时正确清除此代码？

这是它的工作方式：

| Employee ID | Status |  

E100             Deactivated 

E100            Activated

变成：

| Employee ID | Status | Status | 

  E100        Deactivated  Activated

代码：

Sub mergeCategoryValues()
Dim lngRow As Long
Dim rngPrimaryKey As Range

Application.ScreenUpdating = False
Application.EnableEvents = False


'This is using activesheet, so make sure your worksheet is
' selected before running this code.
Sheets("Consolidated").Activate

With ActiveSheet

     Set rngPrimaryKey = .Range("A:Z").Find("Full Name")

    Dim columnToMatch As Integer
    columnToMatch = rngPrimaryKey.Column

    'Figure out the last row
    lngRow = .Cells(1000000, columnToMatch).End(xlUp).Row

    .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes

    For Each Cell In ActiveSheet.UsedRange
    If Cell.Value <> "" Then
    Cell.Value = Trim(Cell.Value)
    End If
    Next Cell

    'Loop through each row starting with last and working our way up.
    Do

        'Does this row match with the next row up accoding to the Job Number in Column A?
        If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then

            'Loop through columns B though P
            For i = 1 To 1000 '1000 max (?)

                'Determine if the next row up already has a value. If it does leave it be
                '   if it doesn't then use the value from this row to populate the next
                '   next one up.

                If .Cells(lngRow - 1, i).Value <> "" Then 'if not blank
                    If .Cells(lngRow - 1, i).Value <> .Cells(lngRow, i).Value Then 'if previous value is not equal to current value
                    ''''''
                    'INSERT NEW COLUMN HERE
                         If i <> 1 Then 'if column is not "Data Source"
                                If .Cells(lngRow, i).Value <> "" Then
                                 Cells(lngRow - 1, i + 1).EntireColumn.Insert
                                .Cells(lngRow - 1, i + 1).Value = .Cells(lngRow, i).Value
                                'INSERT COLUMN NAME
                                .Cells(1, i + 1).Value = .Cells(1, i).Value
                            End If
                        Else
                        .Cells(lngRow - 1, i).Value = .Cells(lngRow - 1, i).Value & "; " & .Cells(lngRow, i).Value

                    End If
                    Else
                   'Do Nothing
                   End If
              End If
            Next i

            'Now that we've processed all of the columns, delete this row
            '   as the next row up will have all the values
            .Rows(lngRow).Delete
        End If

        'Go to the next row up and do it all again.
        lngRow = lngRow - 1
    Loop Until lngRow = 1
End With


With ActiveWindow
    .SplitColumn = 1
    .SplitRow = 0
End With

ActiveWindow.FreezePanes = True

Worksheets("Consolidated").Range("A:Z").Columns.AutoFit

Application.ScreenUpdating = True
Application.EnableEvents = True

If Err <> 0 Then
    MsgBox "An unexpected error no. " & Err & ": " _
    & Err.Description & " occured!", vbExclamation
End If


End Sub

Answer 1

您只需单击几下即可使用数据透视表，即可提供相同的信息值。

如果要用单词替换数字，则可以复制数据透视表并为每列执行查找/替换。

VBA代码导致错误：“没有足够的内存来完成此操作”

1 个答案: