My code works almost as desired. It checks all sheets for a certain value in Column "F" and then copies its associated row to the active sheet. I can make the code copy the entire row, singular columns "A", or sequential ranges "A:C". I cannot seem to make it copy specific columns like "A" "C" & "F" which is what I need it to do.
Public Sub List()
Dim ws As Worksheet
Dim i As Integer
ActiveSheet.Rows("3:" & ActiveSheet.Rows.Count).Clear
Selection.Clear
For Each ws In Worksheets
If ws.Name <> ActiveSheet.Name Then
For i = 1 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "F").Value = "Pending" Then
ws.Cells(i, "A").Columns("A:D").Copy Destination:=ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
End If
Next
As following from comments to Question, correct answer is to use following line:
ws.Range("A" & i & ", C" & i & ", E" & i).Copy Destination:=ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
instead
ws.Cells(i, "A").Columns("A:D").Copy Destination:=ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Related
I'm basically writing a clean up program to make it more straight forward to access data. Anywho, I ran into possibly a nomenclature error. I want to use the "current" cell in a "for" loop to delete that row and the next 3 rows. Code looks something like this:
For Each SingleCell In SingleSheet1.Range("a1:a40")
If SingleCell.Value = "S" Or SingleCell.Value = "B" Then
Range(SingleCell.Range, SingleCell.Range.Offset(4, 0)).EntireRow.Delete Shift:=xlUp
Else
End If
Next
I tried to define the range to delete as specified in the code but it gave me a runtime error
Delete backwards looping trough row number:
Sub EXAMPLE_1()
Dim i As Long
For i = 40 To 1 Step 1
If Range("A" & i).Value = "S" Or Range("A" & i).Value = "B" Then Range("A" & i & ":A" & i + 3).EntireRow.Delete Shift:=xlUp
Next i
End Sub
Sub EXAMPLE_2()
Dim i As Long
Dim LR As Long 'in case last row is not always number 40, adapt it dinamically
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step 1
If Range("A" & i).Value = "S" Or Range("A" & i).Value = "B" Then Range("A" & i & ":A" & i + 3).EntireRow.Delete Shift:=xlUp
Next i
End Sub
Your code looses the reference for the deleted rows and you should iterate backwards, if you like iteration between cells (which is slow), but a better/faster solution will be to build a Union range and delete all rows at the code end, at once:
Sub testDeleteOffset()
Dim sh As Worksheet, Urng As Range, i As Long
Set sh = ActiveSheet
For i = 1 To 40
If sh.Range("A" & i).Value = "S" Or sh.Range("A" & i).Value = "B" Then
addToRange Urng, sh.Range("A" & i, "A" & i + 3)
i = i + 4
End If
Next i
If Not Urng Is Nothing Then Urng.EntireRow.Delete xlUp
End Sub
If the involved range is huge, a better solution will be to place some markers for the necessary rows (after last existing column), sort on that marker column and delete the (consecutive marked) rows. Another column with the initial order would be necessary to re-sort according to it at the end... The idea is that building a Union range having more than 1000 areas may become slow.
I have two worksheets, named "Monthly" and "Index", in a workbook.
In Index, cell A1 will have a value after some calculations.
I need to copy that value into "Monthly" Column "J".
It shall be one by one using next row coding.
Private Sub CommandButton2_Click()
Dim i As Integer
a = Worksheets("Monthly").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
Range("K" & i).Copy Worksheets("Rule of 78").Range("D6")
'Range("A1").Offset(i - 1, 0).Copy Range("C1")
Range("I" & i).Copy Worksheets("Rule of 78").Range("D7")
Range("E" & i).Copy Worksheets("Rule of 78").Range("D8")
Range("A" & i).Copy Worksheets("Rule of 78").Range("D10")
Worksheets("Index").Range("C2").Copy " How to paste in Monthly sheet
column J, for every row, C2 is different"
Next i
End Sub
Does "A1" have a formula? If so Excel is probably copying a formula, thus the error.
Try:
Worksheets("Index").Range("A1").Copy
Worksheets("Monthly").Range("J" & i).PasteSpecial xlPasteValues
Edit: "A1" or "C2", I didn't get wich is giving you the error.
Sorry if this had been discussed already, I am struggling with the syntax of the ranges that I need to copy and paste. I am trying to do so without using the clipboard and found out that I could do it with .Value = .Value (Excel VBA Copy and Paste (without using Copy+Paste functions) on empty row)
There are two workbooks, I am copying from wbsource.Worksheets(1) to wb1.ws
The argument is - if column L&row has a "Yes" then ... E.g. if L5 equals Yes, then copy A5:L5 and paste in the first empty row in wb1.ws.
Part of my code is
If .Cells(rw, 12) = "Yes" Then
Dim lastrw As Long
lastrw = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
wbsource.Worksheets(1).???? = ws.Range("A" & lastrw).Value
End If
I would really appreciate it if you could help me with the syntax of this
I believe the following should work for you:
If wbsource.Worksheets(1).Cells(rw, 12) = "Yes" Then
Dim lastrw As Long
lastrw = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ws.Range("A" & lastrw & ":L" & lastrw).Value = wbsource.Worksheets(1).Range("A" & rw & ":L" & rw).Value
End If
In my excel sheet I have the following code:
=IF(ISERROR(MATCH(D2,'Sheet 2'!A:A,0)),"",NOW())
This basically checks to see if the value in D2 matches any values in column A:A in sheet 2, and then populates the cell with a date and time with NOW().
My problem is the date and time is counting up because I am using the NOW() function whereas what I need is the date to, in a way, take a snapshot of the date or freeze the date. This table I am creating is acting like a log so I need the date to stay as it is when it is put into the cell.
Any help with this is much appreciated.
You could have this automatically run, if you paste it in the code behind your sheet (Where the range theCells is the column where the timestamps are going):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("theCells")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Range(Target.Address).Value <> "" Then
Range(Target.Address).Copy
Range(Target.Address).PasteSpecial xlPasteVaues
End If
End Sub
Ok so I solved it, In my VBA I have the following code which pretty much creates a log file when my button is clicked, it takes various information in different cells and populates it in the next defined available row:
Sub copylog()
Dim LastRow As Long, ws As Worksheet
Dim wt As Worksheet
Set ws = Sheets("Create Log")
Set wt = Sheets("PDF Creation")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = wt.Range("N11").Value
ws.Range("B" & LastRow).Value = wt.Range("N12").Value
ws.Range("C" & LastRow).Value = wt.Range("N13").Value
ws.Range("D" & LastRow).Value = wt.Range("N14").Value
ws.Range("E" & LastRow).Value = wt.Range("N15").Value
ws.Range("F" & LastRow).Value = wt.Range("N16").Value
ws.Range("G" & LastRow).Value = wt.Range("AT19").Value
ws.Range("H" & LastRow).Value = wt.Range("AT21").Value
ws.Range("I" & LastRow).Value = wt.Range("AT23").Value
ws.Range("J" & LastRow).Value = wt.Range("AT25").Value
ws.Range("K" & LastRow).Value = wt.Range("AT27").Value
ws.Range("L" & LastRow).Value = wt.Range("A2").Value
ws.Range("M" & LastRow).Value = Environ("Username")
End Sub
The code above will populate a table in the next available row, for example, the first line:
ws.Range("A" & LastRow).Value = wt.Range("N11").Value
This will take the value that populates N11 in the PDF create sheet and populate the next available row in column A in the create log sheet (using copy and paste).
The line that has fixed my time problem is the line:
ws.Range("L" & LastRow).Value = wt.Range("A2").Value
In cell A2, I have the NOW() function and the button copies and pastes it into the next available space in column L (copies and pastes as TEXT).
I'm looking to filter and move data from a main excel spreadsheet (sheet 1) into a new sheet (sheet 2) but all the advice I've found so far relates to filtering just one column of data and I want to move two. I also need to filter by a wildcard.
I've attached an image of my sheet 1, and what I'd ideally want to create in sheet 2.
Column A is date; column B is animal type; column C is weight.
I need to filter by a wildcard to find all the 'horses' in column B and then move the date, the animal type and the weight to spreadsheet 2.
I've managed to do the first part using
=IF(COUNTIF(Sheet1!B2,"*horse*"),Sheet1!B2,"")
but I'm stuck on the 2nd part of removing all the blank rows.
Animal weights
try this
Option Explicit
Sub horses()
With Worksheets("Sheet1").Range("B2:D100") '<== range containing data, headers included
.Sort key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
.AutoFilter field:=2, Criteria1:="*Horse"
If WorksheetFunction.Subtotal(103, .Cells) > .Columns.Count Then
.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Sheet2").Range("A1") '<== copying form cell "A1" of "Sheet2"
End If
End With
End Sub
adapt commented lines as per you needs
Use the below function to get your result. You can parse any content to this function to get the result in Sheet2.
Private Function filtercontent(content As String) As String
Lastrow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If InStr(Cells(i, 2), content) > 0 Then
Worksheets("Sheet1").Range("A" & i, "C" & i).Copy
With Worksheets("Sheet2")
.Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
End With
End If
Next i
End Function
or
Private Function filtercontent(content As String) As String
Dim Lastrow As Long
Dim i As Integer
Lastrow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If InStr(Cells(i, 2), content) > 0 Then
Worksheets("Sheet1").Range("A" & i, "C" & i).Copy Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next i
End Function
for example if you want the apply the filter for Horse then
Sub testing()
filtercontent ("Horse")
End Sub