私はいくつかのサブルーチンを作成し、テスト段階では 5 つのファイルでうまく機能しましたが、それらを実際のデータ (つまり 600 ファイル) で動作させると、しばらくすると次のメッセージが表示されます。
Excel は、利用可能なリソースではこのタスクを完了できません。少ないデータを選択するか、他のアプリケーションを閉じてください。
私はそれをグーグルで検索しましたが、私が見つけたほとんどは でしapplication.cutcopymode = falseたが、私のコードではカットアンドコピーモードを使用していませんが、コピーを処理します
destrange.Value = sourceRange.Value
そして、デバッグに行くと、エラープロンプトの後に、この同じコード行に移動します。誰かが同様の状況に遭遇し、問題を解決する方法を知っていれば、私は感謝します.
自分自身を明確にするために、私は試してみapplication.cutcopymode = falseましたが、役に立ちませんでした。この 600 個のファイルをそれぞれ開いて、さまざまな条件で並べ替え、最初の 100 個を新しいワークブックに (次々に) コピーし、1 つの条件で終了したら、その新しいワークブックを保存して閉じ、新しく開き、データの抽出を続けます。異なる基準。
誰かが助けに興味を持っている場合は、コードを提供することもできますが、質問を簡単にするために提供しませんでした. どんな助けや提案も大歓迎です。ありがとうございました。
編集：
ここにメインサブがあります：（最初の100、次に50、次に20、次に10をコピーする必要があるため、コピーする最初の行の数に関する情報をワークブックから取得することが目的です...）
Sub final()
Dim i As Integer
Dim x As Integer
For i = 7 To 11
x = ThisWorkbook.Worksheets(1).Range("N" & i).Value
Maximum_sub x
Minimum_sub x
Above_Average_sub x
Below_Average_sub x
Next i
End Sub
そして、これがこのサブの 1 つです: (その他は基本的に同じで、並べ替え基準が変更されているだけです。)
Sub Maximum_sub(n As Integer)
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long
Dim srt As Sort
' The path\folder location of your files.
MyPath = "C:\Excel\"
' If there are no adequate files in the folder, exit.
FilesInPath = Dir(MyPath & "*.txt")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of adequate files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
'get a number: take a top __ from each
'n = ActiveWorkbook.Worksheets(1).Range("B4").Value
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
' Change this to fit your own needs.
' Sorting
Set srt = mybook.Worksheets(1).Sort
With srt
.SortFields.Clear
.SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlDescending
.SetRange Range("A1:C18000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Deleting nulls
Do While (mybook.Worksheets(1).Range("C2").Value = "null")
mybook.Worksheets(1).Rows(2).Delete
Loop
Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1)
SourceRcount = sourceRange.Rows.Count
Set destrange = BaseWks.Range("A" & rnum)
BaseWks.Cells(rnum, "A").Font.Bold = True
BaseWks.Cells(rnum, "B").Font.Bold = True
BaseWks.Cells(rnum, "C").Font.Bold = True
Set destrange = destrange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
mybook.Close savechanges:=False
Next FNum
BaseWks.Columns.AutoFit
End If
BaseWks.SaveAs Filename:="maximum_" & CStr(n)
Activewoorkbook.Close
End Sub