Question

下午好，

我正在尝试读取csv文件的数量并将其加载到新工作簿中。然后创建代码以从每列中找到最大数字（即最大值）并粘贴在每列的底部。在这个论坛的帮助下，我已经完成了计算最大价值和在lastrow中粘贴的阶段。

现在我正在尝试将它们传输到我创建的新工作表中，并使用我的代码命名为结果。根据以前的建议，我已经找到了如何使用以下示例将特定范围从一列粘贴到另一个工作表：

Sub OneCell()
   Sheets("Result").Range("E3:V3").Value = Sheets("HP5_1gs_120_2012.plt").Range("E3:V3").Value
End Sub

但不确定如何使用现有代码循环显示我的最大值（在图1中以黄色突出显示）并粘贴到结果表中，并将标题从E列粘贴到最后一个可用列和rowname作为工作表名称。每个运行的每个工作表的数据结构都相同。并且我的开始列始终是列“E”，但是每个运行的结束列（即最后一列）可以是不同的。这就是我对如何循环这个问题感到非常困惑。因此，对于一个示例，如下所示的简单数据集（图1）：

enter image description here

我正在努力实现这一目标（图2）：

enter image description here

我的主要代码如下：

Private Sub FilePath_Button_Click()
get_folder
End Sub

Private Sub Run_Button_Click()
load_file
End Sub

Public Sub get_folder()

Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .Show
  On Error Resume Next
  FolderName = .SelectedItems(1)
  Err.Clear
  On Error GoTo 0
End With
TextBox1.Text = FolderName
End Sub

Sub load_file()
Dim strFile As String
Dim ws As Worksheet
Dim test As String

Dim wb As Workbook

test = TextBox1.Text

strFile = Dir(Me.TextBox1.Text & "\*.csv")

       Set wb = Workbooks.Add
        'added workbook becomes the activeworkbook
       With wb
       Do While Len(strFile) > 0

        Set ws = ActiveWorkbook.Sheets.Add
        ws.Name = strFile

With ws.QueryTables.Add(Connection:= _
     "TEXT;" & test & "\" & strFile, Destination:=Range("$A$1"))
    .Name = strFile
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = True
    .TextFileSpaceDelimiter = False

    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
strFile = Dir
Loop
End With

Application.DisplayAlerts = False
Worksheets("Sheet1").Delete
Worksheets("Sheet2").Delete
Worksheets("Sheet3").Delete
Application.DisplayAlerts = True

 Dim ws1 As Worksheet
 Dim ColNo As Long, lc As Long
 Dim lastrow As Long

    For Each ws1 In ActiveWorkbook.Worksheets
       lastrow = Range("A1").End(xlDown).Row
        lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
         For ColNo = 5 To lc
           ws1.Cells(lastrow + 2, ColNo).Formula = "=MAX(" & Split(Cells(, ColNo).Address, "$")(1) & "1:" & Split(Cells(, ColNo).Address, "$")(1) & lastrow & ")"
        Next ColNo
    Next ws1

Dim ws2 As Worksheet
Set ws2 = Sheets.Add
Sheets.Add.Name = "Result"

MsgBox "Job Complete"
End Sub



Private Sub UserForm_Click()

End Sub

我希望我已经设法解释了我想要实现的目标，我真的很感激任何指导。感谢

Answer 1

像下面这样的东西应该这样做。毫无疑问，你会想要调整位，但总体结构是存在的。我评论了每个块正在做什么 - 确保你理解每一行。

但通常在提出问题时，您应该真正将问题分解为其中的部分。

喜欢 - ＆＃34;如何循环播放工作表＆＃34;，然后＆＃34;如何找到工作表的最后一行＆＃34;，然后＆＃34;如何复制范围＆＃34; ;等。

你会发现其中每一个都被问过，所以事实上只需要一点点Stackoverflow就可以了。

Sub example()
    Dim ws As Worksheet, dWs As Worksheet 'variables for ws enumerator and destination ws
    Dim wb As Workbook 'variable to define the workbook context
    Dim sRng As Range, dRng As Range 'variables for source range and destination range

    Set wb = ActiveWorkbook

    'Add the results sheet and assign our current row range
    Set dWs = wb.Worksheets.Add
    Set dRng = dWs.Cells(2, 1)

    'Change the results sheet name (error if name exists so trap it)
    On Error Resume Next
    dWs.Name = "Result"
    On Error GoTo 0

    'Loop worksheets
    For Each ws In wb.Worksheets

        'Only work on the .csv sheet names
        If ws.Name Like "*.csv" Then

            'Find the row with the values on
            Set sRng = ws.Cells(ws.Rows.Count, 4).End(xlUp)
            'And set the range to be to the contiguous cells to the right
            Set sRng = ws.Range(sRng, sRng.End(xlToRight))

            'Add the sheet name to the results col A
            dRng.Value = ws.Name
            'Copy sRng to the output range
            sRng.Copy dRng(1, 2)

            'Increment output row to the next one
            Set dRng = dRng(2, 1)

        End If

    Next ws

    'Now just add the headers
    For Each dRng In dWs.Range(dWs.Cells(1, 2), dWs.Cells(1, dWs.Cells.Find("*", , XlFindLookIn.xlFormulas, , XlSearchOrder.xlByColumns, xlPrevious).Column))
        dRng.Value = "data " & dRng.Column - 1
    Next

End Sub

创建循环以将结果行从多个工作表复制到新工作表

1 个答案: