2

What I want to do is pretty simple, I just have literally 0 experience with VBA. I have experience coding in other languages though (java, js, c, etc.).

What I am trying to do is go through the rows of an excel sheet, see if the integer value in the first cell of each row is within a certain range, and if it is, then copy that entire row and paste it into a new sheet that will be saved as a CSV.

I am able to go through the column and check the first cell value in each row, I now need to know how to take that corresponding row, copy it, and paste it in the CSV sheet.

For example, say this is the excel sheet I am trying to parse:

enter image description here

Say the user specifies that they want to grab all rows where the value in the first cell of that row is between 3 and 9 (rows 6-8, 11, 13-15). My VBA code would then go through all the rows and grab only the rows that fit the criteria above, and then send those rows to a new sheet that would look something like this:

enter image description here

This is what my code looks like right now, which goes down Column A, and checks the value in first cell of each row. I am not sure how to grab each row, and then send it to the new sheet

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

Any help is appreciated!

actuallife
  • 89
  • 7
  • You only need one loop. You also should [find the last row](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba).... `For Each cell in Range("A1:A" & lastRow)`. You may be able to just use `Range.AutoFilter` here instead of looping. – BigBen Dec 11 '20 at 00:15

2 Answers2

1

I suspect your knowledge of VBA far exceeds mine of java etc. The following basic code will do what you want - following on from @BigBen's suggestions regarding finding the last row & using a filter to copy all rows at once.

It assumes the code is in that workbook. You'll need to add your own error traps for invalid user input.

CODE EDITED AS PER OP's REQUIREMENTS

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
  • Thank you! This is super close to what I was describing. Is it possible to have the rows that are grabbed get put into a new sheet within the same workbook as the original sheet rather than save it as its own workbook? Also, am I able to explicitly specify what I want the headers/titles in the first row of this new csv to be rather than copying the first row of the original sheet? – actuallife Dec 11 '20 at 16:38
  • Code amended. Please accept the answer if it now satisfies all requirements. –  Dec 11 '20 at 19:28
  • thank you for the help! One last question, your code seems to copy over the very first row in the original workbook along with the rows I want. How do I make it so it ONLY copies over the rows that fit the criteria? – actuallife Dec 14 '20 at 22:49
  • It shouldn't do: `With Sheet1.Range("A2:A" & LastRow).` is starting from row 2 `A2`. Can't really explain that one?? –  Dec 14 '20 at 23:03
  • my mistake, I for some reason had A1:A, but I think I know why. If I do 'A2:A' , it doesnt have that additional row, but I actually need that additional row because if I don't some of the formulas used in the data I am moving don't work, the cells say !#REF. Do you know if there is a simple change to the code you put to make it so it copies the raw values from the cells rather than copying the data thats determined by a formula? – actuallife Dec 14 '20 at 23:26
  • 1
    Code edited. Note the line to un-comment if you also want the formats copied. Tested & works fine. :) –  Dec 15 '20 at 02:49
  • youre the man, thank you again for the help. 1 last question, when I specify the filter criteria `With Sheet1` .`Range("A:A").AutoFilter Field:=1, Criteria1:=">=" & FirstL, _` `Operator:=xlAnd, Field:=1, Criteria2:="<=" & LastL` `End With` is there a way to instead of using an upper bound for criteria2, can I check to see if the value in the cell is a number (not blank or string)? I want to be able to have the user enter a lower bound and then automatically grab all rows that have a number that is equal or larger than the lower bound. Maybe some sort of isNumber built in method? – actuallife Dec 15 '20 at 23:31
  • 1
    Code now determines maximum value in range. NB Max() tends to ignore text, but dates are treated by Excel as numbers. –  Dec 16 '20 at 03:27
  • Thank you so much man, I really appreciate the help! Out of curiosity and for my own knowledge, what does the `Application.CutCopyMode = False` line at the end do? – actuallife Dec 16 '20 at 17:27
  • 1
    It clears the Clipboard - I added it after we changed the `Copy` method to a `Paste` method. Without it, Excel leaves the flashing lines around the area being copied, telling us that the selection is still in the Clipboard waiting to be pasted somewhere. –  Dec 16 '20 at 20:41
1

Copy with Criteria Using Loop

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
VBasic2008
  • 44,888
  • 5
  • 17
  • 28