0

我有 600 个 .txt 文件 - 但只有当作为 excel 文件打开时，它们才会显示出良好的结构。它们中的每一个都由三列和大约 18000 行组成。

我的任务是打开它们中的每一个，按 C 列中的值降序对它们进行排序，取前 100 个，将它们复制到单独的工作表中，并将第一行加粗（在新工作表中复制的 100 个中的第一行）。因此，最终结果将是一个工作表，该工作表收集了每个文件中所有最大 100 个值，其中粗体行使边界清晰。

我决定用宏来完成工作，但由于我没有 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 回答