Im trying to create a code that will find a particular word on a page and then copy and paste all the cells underneath until a blank cell in another workbook. The only issue i'm finding is that the data shifts when i run it again and there is supposed to be a blank cell.
Sub CopyRows()
Dim Found As Range
Dim ANextFreeCell As Range
Dim BNextFreeCell As Range
Dim wkDest As Worksheet
Set wsDest = Workbooks("sample_bills (version 1).xlsx").Worksheets("sample_bills")
Set Found = Cells.Find(What:="Description", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Found Is Nothing Then
MsgBox "ERROR"
Else
i = Found.Row
j = Found.Column
End If
Do
Set ANextFreeCell = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(RowOffset:=1)
Set BNextFreeCell = wsDest.Cells(Rows.Count, "D").End(xlUp).Offset(RowOffset:=1)
ANextFreeCell = Cells(i + 1, j)
BNextFreeCell = Cells(i + 1, j + 1)
i = i + 1
Loop Until IsEmpty(Cells(i, j)) And IsEmpty(Cells(i, j + 1))
End Sub
Any help would be greatly appreciated :)
To find the last row for multiple columns, use Range("C:D").Find, add 1 to get the next empty row.
NextEmptyRow = ActiveSheet.Range("C:D").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
and then paste using...
ActiveSheet.Cells(NextEmptyRow, "C")
Related
I've a problem here, I've been trying to use VBA to distribute a known number evenly across a range.The problem is that I need to find the way where the numbers in the range be as equal as possible to each other, could you help me? or give ideas?
The data set is as follow
The known number is given by "TV Comodin" Row in color Red, and here is my try:
Sub Prueba()
Columns("A:A").Select
Set Cell = Selection.Find(What:="TV Comodín", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ActiveCell = Cell
Cell.Select
comodin = ActiveCell.Offset(0, 1).Value2
Range("A2").Select
Firstrow = ActiveCell.Row
Selection.End(xlDown).Select
Lastrow = ActiveCell.Row
j = comodin
While (j > 0)
For i = 2 To Lastrow
Range("B2").Select
Range("B" & i) = Range("B" & i).Value + 1
If j > 0 Then j = j - 1
If j = 0 Then Exit For
Next
Wend
End Sub
Basically, my code finds the "TV Comodin" row to get de number of times that the loop is gonna add 1 by 1 in every single row of its column,
Sorry, I'm a little bit new on VBA, thanks by the way.
Here's one approach. Find the smallest number in the range: add one. Repeat until you've done that (eg) 55 times.
Sub Prueba()
Dim f As Range, ws As Worksheet, comodin As Long, rng As Range, m, mn
Set ws = ActiveSheet
Set rng = ws.Range("A2", ws.Range("A2").End(xlDown)).Offset(0, 1)
Set f = ws.Columns("A").Find(What:="TV Comodín", LookIn:=xlFormulas, _
LookAt:=xlWhole, MatchCase:=False)
If Not f Is Nothing Then
rng.Value = ws.Evaluate("=" & rng.Address() & "*1") 'fill empty cells with zeros
comodin = f.Offset(0, 1).Value
Do While comodin > 0
mn = Application.Min(rng)
If mn >= 100 Then Exit Do ' exit when no values are <100
m = Application.Match(mn, rng, 0)
rng.Cells(m).Value = rng.Cells(m).Value + 1
comodin = comodin - 1
Loop
Else
MsgBox "not found!"
End If
End Sub
Im trying to create a loop in excel that will find a word and then copy and paste all cells underneath the word into another workbook until a blank cell.
Im really new to VBA so please bare with
Sub CopyRows()
Dim Found As Range
Dim NextFreeCell As Range
Dim wkDest As Worksheet
Set wsDest = Workbooks("sample_bills (version 1).xlsx").Worksheets("sample_bills")
Set NextFreeCell = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(RowOffset:=1)
Set Found = Cells.Find(What:="Paid", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Found Is Nothing Then
MsgBox "ERROR"
Else
i = Found.Row
j = Found.Column
End If
Do
NextFreeCell = Cells(i, j)
i = i + 1
Loop Until IsEmpty(Cells(i, j))
End Sub
This is what ive got so far but will only copy and paste the word paid into the other workbook, and won't continue to do the rest underneath. Any help would be appreciated :)
Update: Managed to solve this by moving the line
Set NextFreeCell = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(RowOffset:=1)
into the loop
I need your help.
Sorry, I am really new to VBA but, how do I go about converting or adding onto the Excel function below to loop through all the found matches. Right now it only returns 1 match but i'd like to to have it modified to return all occurrences of a match so that I can input it into my userform for processing later.
Private Sub Search_Click()
With Sheet1
Set foundCell = .Cells.find(What:="test", After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Match"" found in row " & foundCell.Row)
form1.location.Value = Cells(foundCell.Row, 1).Value
Else
MsgBox ("No match not found")
End If
End Sub
You can try findnext or add some small edits like something along these lines, just a continuous loop until you run out of matches
Private Sub Search_Click()
Dim rowNum As Long: rowNum = 1
Dim colNum As Long: colNum = 1
Do While ( True )
With Sheet1
Set foundCell = .Cells.find(What:="test", After:=.Cells(rowNum, colNum), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Match"" found in row " & foundCell.Row)
form1.location.Value = form1.location.Value & vbCrLf & Cells(foundCell.Row, 1).Value
if foundCell.Row < rowNum Then Exit Do
rowNum = foundCell.Row
colNum = foundCell.Column
Else
If rowNum = 1 Then MsgBox ("No matches found")
Exit Do
End If
Loop
End Sub
Just in case you need to store data for all cells that contained your search item, you could use the following. Usage: myArray = makeArrayFoundCellInfoInRange("test", Sheets.("Sheet1").Range("A1:Z500"))
'**************************************************************************************************************************************************************
'To return an array of information (value, formula, address, row, and column) for all the cells from a specified Range that have the searched item as value
'Returns an empty array if there is an error or no data
'**************************************************************************************************************************************************************
Public Function makeArrayFoundCellInfoInRange(ByVal itemSearched As Variant, ByVal aRange As Variant) As Variant
Dim cell As Range, tmpArr As Variant, x As Long
tmpArr = Array()
If TypeName(aRange) = "Range" Then
x = 0
For Each cell In aRange
If itemSearched = cell.Value Then
If x = 0 Then
ReDim tmpArr(0 To 0, 0 To 4)
Else
tmpArr = reDimPreserve(tmpArr, UBound(tmpArr, 1) + 1, UBound(tmpArr, 2))
End If
tmpArr(x, 0) = cell.Value
tmpArr(x, 1) = cell.Formula
tmpArr(x, 2) = cell.Address(0, 0) 'Without the dollar signs
tmpArr(x, 3) = cell.Row
tmpArr(x, 4) = cell.Column
x = x + 1
End If
Next cell
End If
makeArrayFoundCellInfoInRange = tmpArr
Erase tmpArr
End Function
I have an Excel sheet that has data grouped using the outline method.
I'm having issues defining a range from the beginning of the group to the end of the group.
I have this data populating a listbox in a userform.
If a user selected any item in this group to delete I need to remove the whole group.
I think I am over thinking it but is there a good way to define this range?
Here is a sample of what I am starting with below
`Sub delrows()
Dim StartRow As Integer
Dim EndRow As Integer
'if outline level should never drop below 2.
'If it is 2 then this will always be the beginning of the range.
If ActiveCell.Rows.OutlineLevel = 2 Then
y = ActiveCell.Row
Else
y = ActiveCell.Row + 3
'y= needs to look up until it see a 2 then go back down 1 row
End If
If ActiveCell.Rows.OutlineLevel <> 2 Then
x = ActiveCell.Row + 1
'x = needs to look down until it finds next row 2 then back up 1 row
Else
x = ActiveCell.Row
End If
StartRow = y
EndRow = x
Rows(StartRow & ":" & EndRow).Select '.Delete
End Sub`
Worked on it a little bit. Have the outline level stored as a value on the sheet in column AA.
Sub delrows()
Dim StartRow As Integer
Dim EndRow As Integer
Dim Rng As Range
Dim C As Range
Dim B As Range
'if outline level shoudl never drop below 2.
'If it is 2 then this will always be the begining of the range.
If ActiveCell.Rows.outlinelevel = 2 Then
'If ActiveCell = 2 Then
y = ActiveCell.Row
Else
Set Rng = Range("AA:AA")
Set B = Rng.Find(What:="2", After:=ActiveCell,LookIn:=xlFormulas,LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
y = B.Offset(0, 0).Row
End If
If ActiveCell.Rows.outlinelevel <> 2 Then
Set Rng = Range("AA:AA")
Set C = Rng.Find(What:="2", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
x = C.Offset(-1, 0).Row
Else
If ActiveCell.Rows + 1 = 3 Then
Set Rng = Range("AA:AA")
Set C = Rng.Find(What:="2", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
x = C.Offset(-1, 0).Row
Else
x = ActiveCell.Row
End If
End If
StartRow = y
EndRow = x
Rows(StartRow & ":" & EndRow).Delete
End Sub
Try this:
Option Explicit
Public Sub RemoveGroup()
Dim grpStart As Range, grpEnd As Range, lvl As Long
Set grpStart = Sheet1.Range("A7").EntireRow 'test cell - A7
Set grpEnd = grpStart
lvl = grpStart.OutlineLevel
While lvl = grpStart.OutlineLevel 'find start of current group (up)
Set grpStart = grpStart.Offset(-1)
Wend
Set grpStart = grpStart.Offset(1) 'exclude 1st row in next group
While lvl = grpEnd.OutlineLevel 'find end of current group (down)
Set grpEnd = grpEnd.Offset(1)
Wend
Set grpEnd = grpEnd.Offset(-1) 'exclude 1st row in next group
With Sheet1.Rows(grpStart.Row & ":" & grpEnd.Row)
.ClearOutline
.Delete
End With
End Sub
Before and After:
I am creating a set of csv files in VBA.
My script is creating the data set I need, but the number of rows differs in multiple iterations of the loop. For instance, for i=2, I have 100,000 rows, but for i=3, I have 22,000 rows. The problem is that when Excel saves these separate csv files, it does not truncate the space at the end. This leaves 78,000 blank rows at the end of the file, which is an issue given that I need about 2,000 files to be generated, each several megabytes large. (I have some data I need in SQL, but can't do the math in SQL itself. Long story.)
This problem normally occurs when saving manually - you need to close the file after removing the rows, then reopen, which is not an option in this case, since it's happening automatically in VBA. Removing the blank rows after saving using a script in another language isn't really an option, since I actually need the output files to fit on the drive available, and they are unnecessarily huge now.
I have tried Sheets(1).Range("A2:F1000001").ClearContents, but this does not truncate anything. Removing the rows should have similarly no effect before saving, since Excel saves all rows until the end of the file, as it stores the bottom-right most cell operated on. Is there a way to have excel save only the rows I need?
Here is my code used to save: (The truncation happens earlier, in the routing that calls this one)
Sub SaveCSV()
'Save the file as a CSV...
Dim OutputFile As Variant
Dim FilePath As Variant
OutputPath = ActiveWorkbook.Worksheets("Macro").Range("B2").Value
OutputFile = OutputPath & ActiveWorkbook.Worksheets("Macro").Range("B1").Value
Application.DisplayAlerts = False 'DISABLE ALERT on Save - overwrite, etc.
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True 'DISPLAY ALERTS
End Sub
The relevant bit of code is here:
'While looping through Al, inside of looping through A and B...
'Created output values needed in this case, in an array...
Sheets(1).Range("A2:E90001") = Output
ActiveWorkbook.Worksheets(1).Range("F2").Formula = "=(does not matter, some formula)"
ActiveWorkbook.Worksheets(1).Range("F2").AutoFill Destination:=Range("F2:F90001")
'Set Filename to save into...
ActiveWorkbook.Worksheets("Macro").Range("B1").Value = "Values_AP" & Format(A, "#") & "_BP" & Format(B, "#") & "_Al" & Format(Al, "#")
'Save Sheet and reset...
Call SaveCSV
Sheets(1).Range("A2:F90001").ClearContents
CurrRow = 1
Next Al
You can get the UsedRange to recalculate itself without deleting columns and rows with a simple
ActiveSheet.UsedRange
Alternatively you can automate the manual removal of the "false" usedrange by deleting the areas below the last used cell with code such as DRJ's VBAexpress article, or by using an addin such as ASAP Utilities
The function from DRJ's article is;
Option Explicit
Sub ExcelDiet()
Dim j As Long
Dim k As Long
Dim LastRow As Long
Dim LastCol As Long
Dim ColFormula As Range
Dim RowFormula As Range
Dim ColValue As Range
Dim RowValue As Range
Dim Shp As Shape
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each ws In Worksheets
With ws
'Find the last used cell with a formula and value
'Search by Columns and Rows
On Error Resume Next
Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
On Error GoTo 0
'Determine the last column
If ColFormula Is Nothing Then
LastCol = 0
Else
LastCol = ColFormula.Column
End If
If Not ColValue Is Nothing Then
LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
End If
'Determine the last row
If RowFormula Is Nothing Then
LastRow = 0
Else
LastRow = RowFormula.Row
End If
If Not RowValue Is Nothing Then
LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
End If
'Determine if any shapes are beyond the last row and last column
For Each Shp In .Shapes
j = 0
k = 0
On Error Resume Next
j = Shp.TopLeftCell.Row
k = Shp.TopLeftCell.Column
On Error GoTo 0
If j > 0 And k > 0 Then
Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
j = j + 1
Loop
If j > LastRow Then
LastRow = j
End If
Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
k = k + 1
Loop
If k > LastCol Then
LastCol = k
End If
End If
Next
.Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete
.Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Excel saves the UsedRange. In order to truncate the UsedRange, you need to delete whole rows and save the file.
If that's not an option, insert a new worksheet, copy the prepared data to it (thus leaving its UsedRange matching actual data), use Worksheet.SaveAs (as opposed to Workbook.SaveAs) and delete the worksheet.
Although the actual problem here is why your UsedRange gets that big in the first place.