Reputation: 89
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:
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:
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!
Upvotes: 2
Views: 1127
Reputation:
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
Upvotes: 1
Reputation: 54983
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
Upvotes: 1