如何使用 VBA 复制 Excel 工作表中的行并将它们发送到 CSV？

Question

我想要做的很简单，我对 VBA 的经验几乎是 0。不过，我有使用其他语言（java、js、c 等）编码的经验。

我要做的是遍历excel表的行，查看每行第一个单元格中的整数值是否在一定范围内，如果是，则复制整行并粘贴到将保存为 CSV 的新工作表中。

我能够遍历该列并检查每一行中的第一个单元格值，我现在需要知道如何获取相应的行，将其复制并粘贴到 CSV 表中。

例如，假设这是我要解析的 excel 表：

假设用户指定他们想要抓取该行第一个单元格中的值介于 3 和 9 之间的所有行（第 6-8、11、13-15 行）。然后，我的 VBA 代码将遍历所有行并仅抓取符合上述条件的行，然后将这些行发送到一个看起来像这样的新工作表：

这就是我的代码现在的样子，它沿着 A 列向下，并检查每行第一个单元格中的值。我不确定如何抓取每一行，然后将其发送到新工作表

Sub exportDesiredRowsToCSVSheet()

    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "myCSV"
    MsgBox "Sheet 'myCSV' was created"     'create new sheet that I will save as CSV at the end
    
    
    firstL = Application.InputBox("first line item num", "please enter num", , , , , , 1) 'gets user to input lower bound
    lastL = Application.InputBox("last line item num", "please enter num", , , , , , 1) 'gets user to input upper bound

    
    For Each Row In Range("A:A")        'go through rows in column A
        For Each Cell In Row            'go through first cell in each row of column A
            If Cell.Value >= firstL And Cell.Value <= lastL Then    'if the value in the cell is in the range
                'Here I want to take the desired rows and copy/paste them to a the newly created 'myCSV' sheet
                
            End If
        Next
    Next
        
    

End Sub

感谢任何帮助！

Answer 1

使用循环复制条件

Option Explicit

Sub exportDesiredRowsToCSVSheet()
    
    ' Define constants.
    Const srcName As String = "Sheet1"
    Const dstName As String = "myCSV"
    Const cCol As String = "A"
    Const FirstRow As Long = 2
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define Source worksheet.
    Dim src As Worksheet
    Set src = wb.Worksheets(srcName)
    
    ' Determine min and max.
    Dim minID As Long
    minID = Application.Min(src.Columns(cCol))
    Dim maxID As Long
    maxID = Application.Max(src.Columns(cCol))
    
    ' Get user input.
    Dim FirstL As Variant
    FirstL = Application.InputBox("First line item number", "Enter Number", _
        minID, , , , , 1)
    If FirstL = False Then
        MsgBox "User canceled."
        Exit Sub
    End If
    Dim LastL As Variant
    LastL = Application.InputBox("Last line item number", "Enter Number", _
        maxID, , , , , 1)
    If LastL = False Then
        MsgBox "User canceled."
        Exit Sub
    End If
    
    ' Determine rows.
    FirstL = Application.Match(FirstL, src.Columns(cCol), 0)
    If IsError(FirstL) Then
        FirstL = Application.Match(minID, src.Columns(cCol), 0)
    End If
    LastL = Application.Match(LastL, src.Columns(cCol), 0)
    If IsError(LastL) Then
        LastL = Application.Match(maxID, src.Columns(cCol), 0)
    End If
    If LastL < FirstL Then
        maxID = FirstL
        FirstL = LastL
        LastL = maxID
    End If
    
    ' Define Destination worsheet.
    Dim dst As Worksheet
    On Error Resume Next
    Set dst = wb.Worksheets(dstName)
    On Error GoTo 0
    If Not dst Is Nothing Then
        Application.DisplayAlerts = False
        dst.Delete
        Application.DisplayAlerts = True
    End If
    Set dst = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    dst.Name = dstName
    
    ' Copy form Source to Destination worksheet.
    Dim rng As Range
    Dim cel As Range
    Dim dRow As Long
    src.Rows(1).Copy dst.Rows(1)
    Set rng = src.Range(src.Cells(FirstL, cCol), src.Cells(LastL, cCol))
    dRow = 1
    For Each cel In rng.Cells
        If cel.Value > 0 Then
            dRow = dRow + 1
            cel.EntireRow.Copy dst.Rows(dRow)
        End If
    Next cel
    
    ' Save as '.csv'.
    dst.Move ' or 'dst.Copy' if you wanna keep a copy in Source workbook.
    With ActiveWorkbook
        '.SaveAs ThisWorkbook.Path & "\" & dstName, xlCSV
        '.FollowHyperlink ThisWorkbook.Path ' Show in windows explorer.
        '.Close
    End With
    
    'wb.Save
    
    ' Inform user.
    MsgBox "'" & dstName & "' was created", vbInformation

End Sub

Answer 2

我怀疑您对 VBA 的了解远远超过了我对 java 等的了解。以下基本代码将满足您的需求 - 遵循 @BigBen 关于查找最后一行和使用过滤器一次复制所有行的建议。

假定代码在该工作簿中。您需要为无效的用户输入添加自己的错误陷阱。

根据 OP 的要求编辑代码

Option Explicit
Sub CopyToCSV()
Dim LastRow As Long, FirstL As Integer, LastL As Integer

FirstL = InputBox("Pick the first Row number", "First Row Selection")
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

'EDIT - maximum number in range selected automatically
LastL = Application.WorksheetFunction.Max(Sheet1.Range("A2:A" & LastRow))

'Left in case you change your mind
'LastL = InputBox("Pick the final Row number", "Final Row Selection")

'***************************************************
'You'll need to determine your own Error Traps here
'***************************************************

With Sheet1
    .Range("A:A").AutoFilter Field:=1, Criteria1:=">=" & FirstL, _
    Operator:=xlAnd, Field:=1, Criteria2:="<=" & LastL
End With

'Create new sheet rather than new csv workbook
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)).Name = "myCSV"

'Add new headers - change to suit
Sheets("myCSV").Cells(1).Resize(1, 5).Value = _
Array("NewH1", "NewH2", "NewH3", "NewH4", "NewH5")

'Copy to new sheet in this workbook assumes data is on sheet 1
'Copy values only (and formats?)
With Sheet1.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    .EntireRow.Copy
    Sheets("myCSV").Range("A2").PasteSpecial Paste:=xlPasteValues
    '*** UNCOMMENT THE NEXT LINE IF YOU ALSO WANT FORMATS COPIED ***
    'Sheets("myCSV").Range("A2").PasteSpecial Paste:=xlPasteFormats
End With

Application.CutCopyMode = False
Sheet1.AutoFilterMode = False

End Sub