The following code works fine. However I need to paste the data starting from a specific row in a column. Here as per the code I can paste the data in column 'C' but if I want to start the pasting from 'C5' for instance how do I change the coding? Thanks for the help.
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim rData As Range, rCell As Range, rFrom As Range, rTo As Range
Dim lRightCol As Long
Dim ass As Integer
ass = 4
With ActiveSheet
lRightCol = .Range("C3").Column
Set rData = .Range(.Range("A3"), .Range("D" & .Rows.Count).End(xlUp))
For Each rCell In rData
Set sh = Nothing
On Error Resume Next
Set sh = Worksheets(rCell.Value)
On Error GoTo 0
If Not sh Is Nothing Then
Set rFrom = rCell.Resize(1, lRightCol)
With sh
Set rTo = .Range("C" & .Rows.Count).End(xlUp).Offset(1).Resize(1, lRightCol)
End With
rFrom.Copy rTo
End If
Next rCell
End With
End Sub
I tried to change the code to following but didn't work.
Set rTo = .Range("C5" & .Rows.Count).End(xlUp).Offset(1).Resize(1, lRightCol)
As I mentioned in comments. you can use:
Set rTo = .Range("C" & Application.Max(5,.Cells(.Rows.Count,"C").End(xlUp).Row + 1))
Related
I have a list of product details in excel, headers in row 2, products details from row 3.
In column C, I have status of either Open or Closed and I want vba codes that can delete the whole range if the list is Open only, hence, no Closed if found. If data has both Closed and Open or just Closed, I don't have to do anything, just leave the data as it is.
This is part of the larger codes I have already written, so that is why I am hoping to achieve this using vba codes.
I am not sure if I need to set my range to column C and how to interpret rng.Cells(q, 1).Value. Right now it looks like my codes just step through and no error but nothing happens. I have provided pic of my test data and results.
Sub test()
Dim Satus As Worksheet
Dim LR1, q As Long
Dim rng As Range
Set Status = Worksheets("Sheet1")
LR1 = Status.Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Status.Range("B2:G" & LR1)
For q = 3 To LR1
If InStr(1, rng.Cells(q, 1).Value, "Closed") = 0 Then
Else
Status.Columns("B:G").EntireColumn.Delete
Status.Range("B2").Value = "No Closed Status"
End If
Next q
End Sub
It's much simpler by directly working with objects and using Excel's native functions:
Option Explicit
Sub Test()
Dim Status As Worksheet
Set Status = Worksheets("Sheet1")
With Status
Dim LR1 As Long
LR1 = .Range("B" & .Rows.Count).End(xlUp).Row
If .Range("C3:C" & LR1).Find("Closed", lookat:=xlWhole) Is Nothing Then
.Range("C3:C" & LR1).EntireRow.Delete
End If
End With
End Sub
Is Nothing is because .Find returns a range object if it's found. If it doesn't find it it will return, essentially, nothing.
It is simple to use Worksheetfunction countif.
Sub test()
Dim Satus As Worksheet
Dim LR1, q As Long
Dim rng As Range, rngDB As Range
Dim cnt As Long
Set Status = Worksheets("Sheet1")
With Status
LR1 = .Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Status.Range("B2:G" & LR1)
Set rngDB = .Range("c3:c" & LR1)
cnt = rngDB.Rows.Count
If WorksheetFunction.CountIf(rngDB, "Open") = cnt Then
rng.EntireColumn.Delete
.Range("B2").Value = "No Closed Status"
.Range("a1") = "Data1 Result"
End If
End With
End Sub
I think this should solve your problem. You can't decide in the for loop a state for a whole column. You have to collect all single states and execute a change afterwards.
Sub test()
Dim Satus As Worksheet
Dim LR1, row As Long
Dim rng As Range
'Dim lOpen As Long
Dim lClosed As Long
Set Status = ThisWorkbook.ActiveSheet
LR1 = Status.Cells(Rows.Count, "B").End(xlUp).row
Set rng = Status.Range("B2:G" & LR1)
rngStart = 2 ' because of header line
rngEnd = rng.Rows.Count - 1 ' likewise
For row = rngStart To rngEnd
Select Case rng.Cells(row, 2).Value
'Case "Open" ' just in case for future use
' lOpend = lOpend + 1
Case "Closed"
lClosed = lClosed + 1
Case Else
End Select
Next row
If lClosed = 0 Then
rng.EntireColumn.Delete ' delete just the data range
Status.Range("B2").Value = "No Closed Status"
End If
End Sub
I'm Working on a code to find a row which has "1263_Estamp_En" in Range "J1" and wan to select the same column and paste it to another workbook but while running the code excel stop working and restart itself, please help how can I search the range and select the value. Below is the code...
Sub Search()
Dim A As Range
Dim myRng As Range
Dim R As Range
Dim Col
ThisWorkbook.Sheets("Result").Activate
Set R = Range("A1:Z1")
ThisWorkbook.Sheets("Sheet1").Activate
Set A = Range("A1")
myRng = R.Find(what:=Str(A), LookIn:=xlValue)
Cells(myRng.Row, myRng.Column).Select
Col = Selection.Column
Col.select
Range(selection,selection.end(xldown)).copy
Thisworkbook.Sheets("Sheet2").Activate
Range("A1").Pastespecial xlPasteValues
End Sub
I think you are looking for something like the code below (without all the unnecessarily Activate, Selection and Select):
Option Explicit
Sub Search()
Dim A As Range
Dim myRng As Range
Dim R As Range
Dim Col
Set R = Sheets("Result").Range("A1:Z1")
Set A = Sheets("Sheet1").Range("A1")
Set myRng = R.Find(what:=CStr(A.Value), LookIn:=xlValue, lookat:=xlWhole)
If Not myRng Is Nothing Then ' <-- check if Find was successful
' rest of your code goes here
myRng.EntireColumn.Copy <-- copy entire Column where found
Sheets("Sheet2").Range("A1").PasteSpecial xlPasteValues
End If
End Sub
I am stuck at the following problem:
I am going through a certain range trough each item and then trying to create a new worksheet each time there is a new name in the range. (The range has several rows with the same name)
I am getting the range with the following code:
Set r = Range("a6", Range("a6").End(xlDown))
For Each Item In r
If Item.text[i]==item.text[i-1] Then create worksheet
Next Item
I can't figure out how to program the for each
Can anyone give a good suggestion ?
First I think Item is a restricted name.
Second in vb == is not what other languages use.
Third offset(row,Column) will move up/down/left/right
Dim r as range, rng as range
Set r = Range("a6", Range("a6").End(xlDown))
For Each rng In r
If rng <> item.offset(-1) Then
dim ws as worksheet
set ws =worksheets.add
ws.name = rng
end If
Next rng
This?
Set r = Range("a6", Range("a6").End(xlDown))
For Each Item In r
If Item.text[i]==item.text[i-1] Then 'this line has errors, but I'll let you fix it
Set NewSheet = ThisWorkbook.Worksheets.Add
End If
Next Item
Sub aAddworksheet()
Dim rRange As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set rRange = ws.Range("A1:A10")
i = 1
For Each Item In rRange
Debug.Print Item(i)
If i > 1 Then
If Item(i).Value = Item(i - 1).Value Then
Set NewSheet = wb.Worksheets.Add()
End If
End If
i = i + 1
Next Item
End Sub
I am trying to loop through all the worksheets in the activeworkbook to perform a repetitive task.
I currently have the code below:
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value = "x" Then
NextIteration:
End If
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
Next
End Sub
I am sure the problem is that I'm misunderstanding something about how the for each loop actually works. Hopefully someone's answer will allow to better understand.
I really appreciate any help on this.
I made some edits to the code, and now I actually do have an error :) I tried making the changes you suggested for the "with ws.range etc..." piece of the code, and I get the object error 91.
Below is my new and "improved" code.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim intAnchorRow As Integer
Dim intMktCapAnchor As Integer
Dim intSectorAnchor As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In ActiveWorkbook.Worksheets
'Filter out the sheets that we don't want to run
If ws.Range("a9").Value <> "x" Or ws.Name = "__FDSCACHE__" Or ws.Name = "INDEX" Then
'Get the anchor points for getting sort range and the sort keys
''''''THIS IS THE PART THAT IS NOW GIVING ME THE ERROR'''''''
With ws.Range("a1:t100")
intAnchorRow = .Find(what:="sector", LookIn:=xlValues).Row
intSectorAnchor = .Find(what:="sector", LookIn:=xlValues).Column
intMktCapAnchor = .Find(what:="Market Cap", LookIn:=xlValues).Column
End With
'Find the last row and column of the data range
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
Set SortRng = Range(Cells(intAnchorRow + 1, 1), Cells(LastRow, LastCol))
Range(SortRng).Sort key1:=Range(Cells(intAnchorRow + 1, intSectorAnchor), Cells(LastRow, intSectorAnchor)), _
order1:=xlAscending, key2:=Range(Cells(intAnchorRow + 1, intMktCapAnchor), Cells(LastRow, intMktCapAnchor)), _
order2:=xlDescending, Header:=xlNo
End If
Next
End Sub
Thanks again. This has been very helpful for me.
If I've understood your issue correctly, you don't want to use a worksheet with an x in cell A9.
If that's the case I would change the condition of the if statement to check if the cell does not contain the x. If this is true, it enters the rest of the code. If not, it goes to the next iteration.
Also, your NextIteration: doesn't do anything in the If statement.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value <> "x" Then
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
End If
Next
End Sub
The : operator is used to return the code to that line after a goto call.
For example
sub gotoEx()
for i = 1 to 10
if i = 5 then
goto jumpToHere
end if
next i
jumpToHere: '<~~ the code will come here when i = 5
'do some more code
end sub
And of course you can use this structure in your code if you wish, and have the jumpToHere: line just before the next
e.g.
for each ws in wb.Worksheets
if ws.Range("a9").Value = "x" then
goto jumpToHere
end if
'the rest of your code goes here
jumpToHere:
next
I have a function that selects a range based on a whole bunch of criteria from Sheet2. I'm trying to copy this range and to show/paste on Sheet1 or have it show in a message box.
Public Function findrulepos(target As Range, destination As Range) As String
Dim ruleStart As Range
Dim ruleEnd, ruleEnd2 As String
Dim Xcell, PasteRangeIndexCell As Range
Dim RuleRange As Range
Dim LastCell As Range
Dim FirstCell, IndexCell As Range
Dim WholeRule As Range
MaxRule = 100000
MaxRow = 100000
Sheets("ResRules").Select
For i = 2 To MaxRow
If CStr(ThisWorkbook.Sheets("ResRules").Range("A" & i).Value) = CStr(target.Value) Then
Set ruleStart = ThisWorkbook.Sheets("ResRules").Range("B" & i) '.offset(0, 1)
Exit For
End If
Next i
'MsgBox (ruleStart.address)
Set FirstCell = ruleStart.offset(1, -1)
Set IndexCell = FirstCell
Do Until IndexCell.Value <> "" Or IndexCell.Row >= MaxRow
Set IndexCell = IndexCell.offset(1, 0)
Loop
If IndexCell.Value <> "" Then
Set LastCell = IndexCell.offset(-1, 1)
MsgBox (LastCell.Value)
Else
Set LastCell = Nothing
End If
Set WholeRule = ThisWorkbook.Sheets("ResRules").Range("" & ruleStart.address & ":" & LastCell.address & "")
End Function
This is the whole code to give me the range I require
I have added a watch and can see I am getting the correct range i.e. $B$3:$B$6 but cant copy this range to Sheet 1
If your function is being called from a worksheet cell, then copy/paste won't work since that type of function can only return a value to the cell in which it resides. You need a function called from a Sub.
Use the following to get the address:
Sheet1.Range("A1").value = WholeRule.address
or, if you want to copy the actual content in the cells:
WholeRule.copy Sheet1.Range("A1")
thanks guys
worked it out
changed it to a Sub then
Public Sub ReturnRuleButton()
Call findrulepos(ThisWorkbook.Sheets("Main").Cells(2, 5), ThisWorkbook.Sheets("Main").Cells(2, 6))
End Sub