0

私は 600 個の .txt ファイルを持っていますが、Excel ファイルとして開いた場合にのみ、適切な構造が表示されます。それぞれが 3 つの列と約 18000 行で構成されています。

私の仕事は、それらのそれぞれを開き、C 列の値で降順に並べ替え、最初の 100 を取得し、それらを別のワークシートにコピーし、最初の行を太字にすることでした (新しいワークシートにコピーされた 100 の最初の行)。したがって、最終的な結果は、各ファイルから最大 100 個の値をすべて集めた 1 つのワークシートになり、太字の行で境界線が明確になります。

私はマクロで仕事を成し遂げることにしましたが、VBAプログラミングの経験がないので、ググって多くの問題を抱えていましたが、最終的にいくつかの他のマクロを採用した後（主に試行錯誤の方法で）思いつきました解決。そして、それはうまく機能し、うまくいきました。しかし、問題は、このコードが実際にどのように動作するかを理解していないことです。今は別のことをする必要があり、立ち往生しています。

再び同じ 600 の .txt ファイルから始めます。それぞれを開く必要がありますが、今回はそれらを昇順で並べ替え、平均以上のものだけが残るようにフィルター処理し、最初の 100 行を取得してコピーします。別のワークシートで、最初のものを太字にします。

そして、これを達成する方法がわかりません。私の最大の問題は、フィルタリング後、最初の行が実際には行 1 ではなく、値に依存する他の値であるため、範囲を A2:C101 に指定できないことです。

このタスクを達成するためのアドバイスや解決策をありがとう。

編集して自分自身を明確にします：主な問題は、データをフィルタリングするときに最初の100行を取得する方法がわからないことです。これは、フィルタリング後の行数（Excelラベル）が1、2、3のソート後のようではないためです。値についてたとえば、5,6,8,21のようなものを取得できます...だから私の質問は、この範囲を取る方法ですか?

そして、最初のタスクで機能するコードは次のとおりです（面倒だとは思いますが、できる限り最善です）：

Sub MergeAllWorkbooks()
    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, CalcMode As Long

    Dim isEmpty As String
    isEmpty = "null"

    ' Change this to the path\folder location of your files.
    MyPath = "C:\Excel"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' If there are no Excel 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 Excel 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

    ' Set various application properties.
'    With Application
'        CalcMode = .Calculation
'        .Calculation = xlCalculationManual
'        .ScreenUpdating = False
'        .EnableEvents = False
'    End With

    ' 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 = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))

            On Error GoTo 0

            Dim c As Range
            Dim SrchRng As Range
            Dim SrchStr As String
            SrchStr = "null"

            Set SrchRng = mybook.Worksheets(1).Range("C1:C18000")
                Do
                Set c = SrchRng.Find(SrchStr, LookIn:=xlValues)
                If Not c Is Nothing Then c.EntireRow.Delete
                Loop While Not c Is Nothing

            If Not mybook Is Nothing Then
                On Error Resume Next

                    mybook.Worksheets(1).Sort.SortFields.Clear
                    mybook.Worksheets(1).Sort.SortFields.Add Key:=Range("C1:C18000") _
                    , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal

                 ' Change this range to fit your own needs.
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A2:C101")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If

                On Error GoTo 0
                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A.

                       ' With sourceRange
                           ' BaseWks.Cells(rnum, "D").Font.Bold = True
                           ' BaseWks.Cells(rnum, "D"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                       ' End With

                        ' Set the destination range.

                        Set destrange = BaseWks.Range("A" & rnum)

                With mybook.Worksheets(1).Sort
                .SetRange Range("A1:C18000")
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
                End With

                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            BaseWks.Cells(rnum, "A").Font.Bold = True
                            BaseWks.Cells(rnum, "B").Font.Bold = True
                            BaseWks.Cells(rnum, "C").Font.Bold = True
                            'MsgBox (BaseWks.Cells.Address)
                            If ActiveCell.Text = isEmpty Then
                            ActiveCell.Offset(0, 1) = 1
                            ActiveCell.Offset(1).EntireRow.Insert
                            ActiveCell.Offset(1, 1) = 0
                            End If
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
4

1 に答える 1

2

問題は、並べ替えがヘッダーを自動的に挿入していることです。Header 引数をxlNoに設定して、ヘッダーを指定しないでください。

    With mybook.Worksheets(1).Sort
        .SetRange Range("A1:C18000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

次に、sourceRange を A1:A100 として指定できます。

また、Excel の [ツール] メニューでマクロ レコーダーを使用してみましたか? これは、簡潔なコードを提供し、それがどのように機能するかを理解するのに大いに役立つため、その知識を使用してコードを簡素化できます。

編集：

最初に、コピーと貼り付けを使用してフィルター処理されたデータを取得します。

mybook.Worksheets(1).Range("A1:A18000").SpecialCells(xlVisible).Copy
destrange.PasteSpecial xlPasteValues

次に、削除して 100 行を残します。

Dim lLastRow as long
lLastRow = BaseWks.Range("A" & CStr(.Rows.Count)).End(xlUp).Row
'Check we have rows to delete
If lLastRow >= rnum Then
    BaseWks.Range("A" & CStr(rnum + 100) & ":A" & CStr(lLastRow)).EntireRow.Delete
End If
于 2013-02-27T00:06:51.440 に答える