I am very new to VBA and all coding so I'm not very good at even the basics yet.
I have a worksheet in excel with about a dozen different business' Balance Sheets. I need to copy all of the the rows in a specific range based on the Asset name in column D. The specific range I need to copy is in between "Securities" and "Derivatives."
I successfully copied all the lines of data in between the first set of "Securities" and "Derivatives" but my For Loop keeps copying the same first range when I need it to move to the next set of "Securities" and "Derivatives" Data.
I have tried and thought maybe adding a variable to my rngA might work? Any help is appreciated.
'''
Sub ChartReference2()
Dim findrow As Long
Dim findrow2 As Long
Dim rngA As Range
For Each cell In ActiveWorkbook.Worksheets("BS growth").Range("A:A")
If cell.Value = "Asset" Then
Worksheets("BS growth").Activate
findrow = Range("D:D").Find("Securities", Range("D3")).Row
findrow2 = Range("D:D").Find("Derivatives", Range("D" & findrow)).Row
Range("D" & findrow & ":D" & findrow2, Selection.End(xlToRight)).Select
Selection.Copy
End If
Next cell
End Sub
'''
Try this - comments in-line
Sub ChartReference2()
Dim ws As Worksheet, assetRow, f1 As Range, f2 As Range
Set ws = ActiveWorkbook.Worksheets("BS growth")
assetRow = Application.Match("Asset", ws.Columns("A"), 0)
If Not IsError(assetRow) Then 'matched a cell in Col A?
With ws.Columns("D")
Set f1 = .Find("Securities", lookat:=xlWhole, after:=.Cells(assetRow - 1), _
SearchDirection:=xlNext)
If Not f1 Is Nothing Then 'found the value?
Set f2 = .Find("Derivatives", lookat:=xlWhole, after:=f1, _
SearchDirection:=xlNext)
If Not f2 Is Nothing Then 'found the value?
ws.Range(f1, f2).Copy 'copy range
End If
End If
End With
End If
End Sub
Related
I have a constant task at work where I need to copy a list of numbers to another sheet. In that sheet, I need to paste those numbers one by one, in a cell to the right of cells with a certain value(that repeats in a column). (notice that the target table is sorted by that value -"מודל תגובה" and there are hidden rows.
It's hard to explain so I hope the images will do.
I tried to write suitable code but I kept getting different errors.
It seems that problems occur when copying the cell values to the target cells.
Dim i As Integer
i = 4
Do While IsEmpty(Cells(i, 1).Value) = False
Worksheets(1).Select
Cells(i, 1).Copy
Worksheets(2).Select
Cells.Find(What:="מודל תגובה", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Activate
If IsEmpty(ActiveCell.Value) = False Then
Selection.FindNext(After:=ActiveCell).Activate
ActiveCell.Offset(0, -1).Paste
Else
ActiveCell.Offset(0, -1).Select
ActiveCell.Paste
End If
i = i + 1
Loop
sorry for the shitty code(literally my first macro).
The solution would be to loop through the visible cells of the filtered range only.
Make sure the destination is filtered for "מודל תגובה" before running this code. It needs to look like your second image before running this code.
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets(1)
Dim DestinationSheet As Worksheet
Set DestinationSheet = Worksheets(2)
Dim LastRow As Long
LastRow = DestinationSheet.Cells(DestinationSheet.Rows.Count, "B").End(xlUp).Row
Dim VisibleCells As Range
On Error Resume Next 'next line errors if no visible cells so we turn error reporting off
Set VisibleCells = DestinationSheet.Range("A2", "A" & LastRow).SpecialCells(xlCellTypeVisible)
On Error Goto 0 'turn error reporting on or you won't see if other errors occur
If VisibleCells Is Nothing Then 'abort if no cells are visible in the filter
MsgBox "No cells to paste at"
Exit Sub
End If
Dim SourceRow As Long
SourceRow = 4 'start row in your source sheet
Dim Cell As Range
For Each Cell In VisibleCells.Cells 'loop through visible cells
Cell.Value = SourceSheet.Cells(SourceRow, "A").Value 'copy value
SourceRow = SourceRow + 1 'incerease source row
Next Cell
Make sure to define DestinationSheet and SourceSheet with your sheets names.
Try this:
Dim i As Integer
Dim Last_Row as Long
Worksheets(1).Select
'The "1" Of the line below means that the variable gonna count the rows of the first column (A)
Last_Row = Application.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:A" & Last_Row).Copy
Worksheets(2).Select
Range("A1").Select
ActiveSheet.Paste
Does anyone know what other command I need to use to copy the row label "Total WI Expenses" down 4 rows below?
The following code will find the "Total WI Expenses" and copy it to a range, however, I just want to find the total and copy the data to the 4 rows down. They need to be copied and pasted as values.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rw As Long, Cell As Range
For Each Cell In ActiveSheet.Range("B:B")
If Cell.Value = "Total WI Expenses" Then
Cell.EntireRow.copy
Range("A71").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next
End Sub
I sincerely appreciate your assistance.
Instead of running a For loop over the whole(!) column you may check first, if something is in the column, and then .Find the wanted value. If you found a result, then you may use it's row number.
Instead of Copy/Paste you may just assign the Range.Value to get the values without formatting.
This code copies the whole row's values four rows below.
Sub Test()
Dim ws As Worksheet
Dim c As Range
Set ws = ActiveSheet
If WorksheetFunction.CountA(ws.Columns(2)) > 0 Then
Set c = ws.Columns(2).Find( _
What:="Total WI Expenses", _
After:=ws.Cells(1, 2), _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not c Is Nothing Then
ws.Rows(c.Row + 4).Value = ws.Rows(c.Row).Value
End If
Set c = Nothing
End If
Set ws = Nothing
End Sub
I got little project in VBA and stuck on below topic.
I need to select range from searched value to first empty cell in H column.
Selected range should looks like this
Selected Range in Excel:
I searched for specific value in column A and if I found it it's being set as first cell in range. ( It works)
Then I need to find last cell in range which is first empty cell in last column.
This is what I've found and try to use
Sub Button()
Dim StringToFind As String
StringToFind = Application.InputBox("Enter string to find", "Find string")
Worksheets("SS19").Activate
ActiveSheet.Range("A:A").Select
Set cell = Selection.Find(What:=StringToFind, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
cell.Select
With Worksheets("SS19")
Set rr = .Range(ActiveCell, .Cells(.Rows.Count, "H").End(xlUp))
With rr
rr.Parent.Range(.Cells(1, "A"), .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0)).Select
End With
End With
If cell Is Nothing Then
Worksheets("SS19").Activate
MsgBox "String not found"
End If
I tried to searched for first empty cell in prevously selected range so it won't search the whole column but it doesn't work.
Try this...
Dim StringToFind As String
StringToFind = Application.InputBox("Enter string to find", "Find string")
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
With ws
Dim findCel As Range
Set findCel = .Range("A:A").Find(StringToFind, , , xlWhole, , , False, , False)
Dim lRow As Long
lRow = .Range(findCel.Address).Offset(, 7).End(xlDown).Row + 1
Dim rr As Range
Set rr = .Range("A" & findCel.Row & ":" & "H" & lRow)
rr.Select
End With
I find that using the worksheet's match function is easier than Range.Find when searching a single column.
Option Explicit
Sub Button()
Dim stringToFind As String, m As Variant
Worksheets("SS19").Activate
stringToFind = Application.InputBox("Enter string to find", "Find string", Type:=xlTextValues)
With Worksheets("SS19")
m = Application.Match(stringToFind, .Range("A:A"), 0)
If Not IsError(m) Then
If Not IsEmpty(.Cells(m + 1, "H")) Then
.Range(.Cells(m, "A"), .Cells(m, "H").End(xlDown).Offset(1)).Select
Else
.Range(.Cells(m, "A"), .Cells(m, "H").Offset(1)).Select
End If
End If
End With
End Sub
Using .End(xlDown) could be problematic if the first cell under row m in column H was blank and this should be checked for or you might find the selection reaching too far, possibly all the way down to the bottom of the worksheet. Checking for a non-blank cell will catch this potential problem.
EDIT: I may have spotted an issue as soon as posting it the myRange
variables dont seem to be doing anything - so I'm feeling they were
there from a method i was using ages ago and there decided to crop out
I'll remove the whole myRange variable and see what happens
Set myRange = ActiveSheet.Range("1:1")
Set myRange = ActiveSheet.Range("A:A")
EDIT 2: Ok so changing the numCols and numRows functions to only use
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
numRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
They now return the correct row and Column numbers
But now when I run selectBlock() it gives me runtime error 28 "Out of Stack Space"
Hello All, I've been writing code to be able to go through multiple sheets and copy the data across to a master workbook
Im coding this to work on any file depending what you pass to it - which has been fine
What im having problems with is the Functions I have made which find the last populated row for any sheet I pass to it
Sub test()
selectBlock().Select
End Sub
Function selectBlock() As Range
Dim row As Integer: row = numRows() 'Finds last populated row
Dim col As Integer: col = numCols() 'Finds last populated column
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
'sets this area starting from cell A2 as the Range
End Function
Function numCols() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("1:1") 'Checks first row to see how many populated columns there are
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("A:A") 'Checks first columns to see how many populated rows there are
numRows = Range("A" & Rows.Count).End(xlUp).row
End Function
When I call the test Sub it causes Excel to hang then crash with no error code
So i imagine im creating some kind of loop or critical error that isnt handled by excel very well
Any help with this would be really appreciated
I can also understand if how im going about it is incredibly stupid
I used to code in Java and maybe im using techniques or pitfalls that I never got rid of - Im self taught at VBA like most and so never learnt official coding practices for VBA
Lot of things here
Fully qualify your cells
Use Long and not Integer when working with row and columns
Use error handling. This will avoid the Excel crashing.
Try this
Sub test()
On Error GoTo Whoa
selectBlock().Select
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Function selectBlock() As Range
Dim row As Long: row = numRows() 'Finds last populated row
Dim col As Long: col = numCols() 'Finds last populated column
Set selectBlock = ActiveSheet.Range("A2:" & ActiveSheet.Cells(row, col).Address)
End Function
Function numCols() As Long
numCols = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Long
numRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).row
End Function
Replace
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
to
Set selectBlock = Range("A2:" & Cells(row, col).Address)
it looks recursive :P
There are safer ways to find the LastRow and LastCol, I like the Find function.
See more detailed in my code's comments.
Code
Sub test()
Dim Rng As Range
Set Rng = selectBlock
Rng.Select '<-- Not sure why you need to Select ?
End Sub
'============================================================
Function selectBlock() As Range
Dim LastRow As Long
Dim LastCol As Long
LastRow = FindLastRow(ActiveSheet) 'Finds last populated row
LastCol = FindLastCol(ActiveSheet) 'Finds last populated column
Set selectBlock = Range(Cells(2, "A"), Cells(LastRow, LastCol))
End Function
'============================================================
Function FindLastCol(Sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
'============================================================
Function FindLastRow(Sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.row
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
In various places in column E of spreadsheet "Review" I have variables that start with the word "Sustainability:" (e.g., Sustainability: a, Sustainability:B"). Each time it finds one. I want it to copy the cell that is in the same row but two columns to the right. Then I want it to paste into a different sheet (SPSE Tran), starting at B63. Each time it pastes, the destination needs to offset by 1 row so it can paste down until it finds no more "Sustainability:". The code below is a start to this but I am stuck.
The second thing I need it to do (which I don't even know where to start) is to only iterate doing this until it finds a row that says "ONLY FOR TRANSITIONS". This leads into a new section that also includes "Sustainability:" but I don't want it to copy from there.
Thank you!
Sub SubmitData()
Dim RngA As Range
Dim FirstAd As String
Dim DestAd As Range
With Sheets("Review").Range("E:E")
Set RngA = .Find(What:="Sustainability:", lookat:=xlPart)
Set DestAd = Range("B63")
If Not RngA Is Nothing Then
FirstAd = RngA.Address
Do
Range(Cell, Cell.Offset(0, 2)).Copy _
Destination:=Sheets("SPSE Tran").Range(DestAd)
Set RngA = .FindNext(RngA)
Set DestAd = DestAd.Offset(0, 1)
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd
End If
End With
End Sub
Here's your code revamped to use a filter instead of a find loop, and then it gets all the results and copies them to the destination at once:
Sub SubmitData()
Dim ws As Worksheet
Dim rngDest As Range
Dim rngStop As Range
With Sheets("SPSE Tran")
Set rngDest = .Cells(Rows.Count, "B").End(xlUp)
If rngDest.Row < 63 Then Set rngDest = .Range("B63")
End With
Set ws = Sheets("Review")
Set rngStop = ws.Columns("A").Find("ONLY FOR TRANSITIONS", , xlValues, xlPart)
With ws.Range("E1:E" & rngStop.Row)
.AutoFilter 1, "Sustainability:*"
.Offset(1, 2).Copy rngDest
.AutoFilter
End With
End Sub
How about (untested):
RngB = where you find "ONLY FOR TRANSITIONS"
RngBRow = RngB.Row
then change your Loop While .. to
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd And RngA.Row < RngBRow