0

1 つの列の値に基づいていくつかの小さなワークシートに分割する必要がある Excel ワークシートがあります。コードはうまく機能しますが、行 10k を超えるとリソースが不足します。

最後の行を見つけようとしているときに問題があると思うので、メモリの問題を回避するためのより効率的な回避策があるかどうか疑問に思っていました。それとも、とにかくこれは問題ではありませんか？

コードは次のとおりです。

Sub Fill_Cells()

Dim masterSheet As Worksheet
Dim masterSheetName As String
Dim TRRoom As String, tabName As String

Dim lastRowNumber As Long
Dim j As Long

Application.ScreenUpdating = False

masterSheetName = "Master"

Set masterSheet = Worksheets(masterSheetName)

lastRowNumber = masterSheet.Cells.Find("*", SearchOrder:=xlByRows,      SearchDirection:=xlPrevious).Row

j = 4

For Each c In masterSheet.Range("AB4:AB" & lastRowNumber).Cells

  TRRoom = c.Value
  tabName = "TR-" & TRRoom
  localLastRowNumber = Worksheets(tabName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  insertRow = localLastRowNumber + 1

Worksheets(tabName).Rows(insertRow).Value = masterSheet.Rows(j).Value

j = j + 1

Next

End Sub

誰かがこれで私を助けることができれば、私はそれを感謝します.

4

4 に答える 4

1

26 の異なるワークシートを含む 20,000 行のデータセットでこれをテストしたところ、私のマシンではエラーなしで約 20 秒で完了しました。これがうまくいくかどうか教えてください。

Sub Fill_Cells()

    Dim ws As Worksheet
    Dim wsMaster As Worksheet
    Dim rngFound As Range
    Dim rngCopy As Range
    Dim lCalc As XlCalculation
    Dim strFind As String
    Dim strFirst As String

    Set wsMaster = Sheets("Master")

    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    On Error GoTo CleanExit

    For Each ws In Sheets
        If UCase(Left(ws.Name, 3)) = "TR-" Then
            strFind = Mid(ws.Name, 4)
            With wsMaster.Columns("AB")
                Set rngFound = .Find(strFind, , xlValues, xlWhole)
                If Not rngFound Is Nothing Then
                    strFirst = rngFound.Address
                    Set rngCopy = rngFound
                    Do
                        Set rngCopy = Union(rngCopy, rngFound)
                        Set rngFound = .Find(strFind, rngFound, xlValues, xlWhole)
                    Loop While rngFound.Address <> strFirst
                    rngCopy.EntireRow.Copy
                    ws.Cells(ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious).Row + 1, "A").PasteSpecial xlPasteValues
                End If
            End With
        End If
    Next ws

CleanExit:
    With Application
        .CutCopyMode = False
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

    Set ws = Nothing
    Set wsMaster = Nothing
    Set rngFound = Nothing
    Set rngCopy = Nothing

End Sub
于 2013-08-27T17:57:24.513 に答える
1

列のマスター シート (またはそのコピー) を並べ替えTRRoomます。同じエントリはすべてTRRoomグループ化されます。

それぞれについてTRRoom、これが最初に発生したときに、関連するタブの最後の行を見つけるだけで済みますTRRoom。その後、 と の両方がlastRowNumber互いにlocalLastRowNumber歩調を合わせて増加します。

保存する必要があるマスターシートにさらに順序がある場合は、ダミーの列を追加し、ソートする前に 1、2、3 などで自動入力します。TRRoom

于 2013-08-28T06:05:08.363 に答える
0

(解決策ではありません)

次のコマンドを実行すると、イミディエイト ウィンドウに何が表示されますか。

Sub Fill_Cells()

Dim masterSheetName As String
Dim masterSheet As Excel.Worksheet

Dim TRRoom As String
Dim tabName As String

Dim lastRowNumber As Long
Dim j As Long
j = 4

Excel.Application.ScreenUpdating = False

masterSheetName = "Master"
Set masterSheet = Excel.ThisWorkbook.Worksheets(masterSheetName)

lastRowNumber = masterSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each cell In masterSheet.Range("AB4:AB" & lastRowNumber).Cells

    TRRoom = c.Value
    tabName = "TR-" & TRRoom
    localLastRowNumber = Excel.ThisWorkbook.Worksheets(tabName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Debug.Print localLastRowNumber '<<<<<interested to see what values are getting assigned here by printing the values to the immediate window.

    insertRow = localLastRowNumber + 1

    Excel.ThisWorkbook.Worksheets(tabName).Rows(insertRow).Value = masterSheet.Rows(j).Value

j = j + 1
Next cell

End Sub
于 2013-08-27T21:18:19.477 に答える