I'm copying an array (Sheet1!A2:A831) and want to paste it on Sheet2! in every 26th row starting at A1.
I was working with this macro, but I'm having some trouble:
Sub test()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("Sheet1!A2:A831").Copy
For i = 26 To LR Step 26
Range("A" & i).PasteSpecial Paste:=xlPasteFormulas
Next i
End Sub
Is this what you are trying?
Sub test()
Dim LR As Long, i As Long, n As Long
With Sheets("Sheet1")
LR = .Range("A" & .Rows.Count).End(xlUp).Row
n = 1
For i = 2 To LR 'A2:A831
.Range("A" & i).Copy
Sheets("Sheet2").Range("A" & n).PasteSpecial _
Paste:=xlPasteFormulas
n = n + 25
Next i
End With
End Sub
Related
I need to auto number rows if adjacent cell is not blank using VBA.
any one from below codes works perfectly , except if it counter blank cells.
as always, your support is much appreciated.
this the expected output
Sub Fill_Serial_Numbers_Option1()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
Range("A3:A" & Application.Max(2, LastRow)) = Evaluate("ROW(A1:A" & LastRow & ")")
End If
End Sub
Sub Fill_Serial_Numbers_Option2()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
With Range("A3:A" & LastRow)
.Cells(1, 1).value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End If
End Sub
Please, test the next code:
Sub testCountNonBlanks()
Dim sh As Worksheet, lastR As Long, arr, arrA, count As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row: count = 1
If lastR <= 2 Then Exit Sub
arr = sh.Range("B2:B" & lastR).value 'place the range in an array for faster iteration
arrA = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then arrA(i, 1) = count: count = count + 1
Next i
sh.Range("A2").Resize(UBound(arrA), 1).value = arrA
End Sub
If a formula (written in VBA) is allowed, you can use the next variant:
Sub testCountByFormula()
Dim sh As Worksheet, lastR As Long, rngB As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
Set rngB = sh.Range("B2:B" & lastR)
sh.Range("A2:A10").Formula = "=IF(B2<>"""",COUNTA(" & rngB.Address & ")-COUNTA(" & rngB.Address(0, 1) & ")+1,"""")"
End Sub
You don't need a macro to accomplish this. Assuming all you care about is blank or not, then you can use a formula like this in cell A9. =Counta($B$1:$B9) If you have formulas you can try to leverage something with COuntif.
You can use a loop from the first row to the last one, something like this:
Sub Fill()
Dim LastRow As Long
Dim Count As Integer
Dim Row As Integer
Count = 0
Row = 1
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Do While Row <= LastRow
If Not (Cells(Row, 2) = "") Then
Count = Count + 1
Cells(Row, 1) = Count
End If
Row = Row + 1
Loop
End Sub
I am attempting to copy Columns D & E from the last row to the next row. Currently I am getting a Compile Error: Type Mismatch. I've been fighting this all day with different ways of going about it. Any help would be appreciated.
Sub PTB()
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
End With
Dim lastCellCoords As String: lastCellCoords = "D" & LastRow & ":E" & LastRow
Dim firstEmptyRow As Integer: firstEmptyRow = LastRow + 1
Dim firstEmptyCoords As String: firstEmptyCoords = "D" & firstEmptyRow & ":E" & firstEmptyRow
If Not LastRow Is Nothing Then
' Now Copy the range:
Worksheets("Survey").Range(lastCellCoords).Copy
' And paste to first empty row
Worksheets("Survey").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Else
MsgBox ("There is no data in specified range")
End If
End Sub
I am having trouble with the below code. "Backend" is the Source Sheet and "Availability" is the Target sheet. Any help is appreciated.
Sub CopyA()
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Backend").Cells(Rows.Count, "AB").End(xlUp).Row
lr2 = Sheets("Availability").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
If Range("Backend!AB" & r).Value = "A" Then
Range("Availability!A" & lr2 + 1 & ":C" & lr2 + 1) =
Range("Backend!V" & r & ":X" & r).Value2
lr2 = Sheets("Availability").Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
End Sub
Based on your code I think you are trying to copy columns V:X from sheet Backend if column AB = A and paste the data into column A of sheet Availability.
This code achieves that:
Sub CopyData()
Dim lastRow As Long, rw As Long
lastRow = Sheets("Backend").Cells(Rows.Count, "AB").End(xlUp).Row
With Worksheets("Backend")
For rw = lastRow To 2 Step -1
If .Range("AB" & rw) = "A" Then
pasteRow = Worksheets("Availability").Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("V" & rw & ":X" & rw).Copy Destination:=Worksheets("Availability").Range("A" & pasteRow & ":C" & pasteRow)
End If
Next rw
End With
End Sub
In your original code you are looping backwards with Step -1. A consequence of this is that the data pasted into Availability will be in reverse order. If you want the pasted data to appear in the order it is found on backend then use this code instead:
Sub CopyData2()
Dim copyRng As Range, cl As Range
Set copyRng = Worksheets("Backend").Range("AB2:AB" & Worksheets("Backend").Cells(Rows.Count, "AB").End(xlUp).Row)
With Worksheets("Availability")
For Each cl In copyRng
If cl = "A" Then
pasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Worksheets("Backend").Range("V" & cl.Row & ":X" & cl.Row).Copy Destination:=.Range("A" & pasteRow & ":C" & pasteRow)
End If
Next cl
End With
End Sub
I'm a total novice with VBA. I have the following code which does a matching exercise and then pastes the relevant values into col. B. my issue is each time the code is used the col will change how can I add this to the module so that it looks for the last cell used in row 1 and pastes the values below.
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Application.ScreenUpdating = False
lastrow1 = Sheets("Input Sheet").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
myname = Sheets("Input Sheet").Cells(i, "B").Value
Sheets("Data").Activate
lastrow2 = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("Data").Cells(j, "A").Value = myname Then
Sheets("Input Sheet").Activate
Sheets("Input Sheet").Cells(i, "c").Copy
Sheets("Data").Activate
Sheets("Data").Cells(j, "B").Select
ActiveSheet.PasteSpecial
End If
Next j
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
End Sub
any assistance with this would be appreciated.
You can replace your second For j = 2 To lastrow2 with the Match function.
Also, there is no need to Activate the sheets back and fourth all the time, just use fully qualified Ranges instead.
Code
Option Explicit
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Dim MatchRng As Range
Application.ScreenUpdating = False
j = 2
With Sheets("Input Sheet")
lastrow1 = .Range("B" & .Rows.Count).End(xlUp).Row
' the 2 lines bellow should be outisde the loop
lastrow2 = Sheets("Data").Range("A" & Sheets("Data").Rows.Count).End(xlUp).Row
Set MatchRng = Sheets("Data").Range("A2:A" & lastrow2)
For i = 2 To lastrow1
myname = .Range("B" & i).Value
If Not IsError(Application.Match(myname, MatchRng, 0)) Then '<-- if successful Match
Sheets("Data").Range("B" & j).Value = .Range("C" & i).Value
j = j + 1
End If
Application.CutCopyMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub
I have the following question, for example, if i have the following data:
Alex 12/9/2013
John 11/30/2013
Irene 10/1/2013
Eve 9/9/2013
Max 1//30/2014
Stanley 1/1/2013
If I want that for every row for which the day is more than 45 days (> 45days), the entire row will be copy down to the next new row. So the result will be original data plus 3 more rows for which the date has been more than 45 days from today. (I need it be more dynamic). I can find some similar samples but was unable to modify it to suit my needs.
Alex 12/9/2013
John 11/30/2013
Irene 10/1/2013
Eve 9/9/2013
Max 1//30/2014
Stanley 1/1/2013
Irene 10/1/2013 Expired
Eve 9/9/2013 Expired
Stanley 1/1/2013 Expired
Code
Sub Macro7()
Range("A1:C1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$7").AutoFilter Field:=3, Criteria1:="yes"
Range("A4:B7").Select
Selection.Copy
Range("A8").Select
ActiveSheet.Paste
ActiveSheet.Range("$A$1:$C$10").AutoFilter Field:=3
Application.CutCopyMode = False
Selection.AutoFilter
Range("C1").Select
Selection.End(xlDown).Select
Range("C8").Select
ActiveCell.FormulaR1C1 = "Expired"
Range("C8").Select
Selection.Copy
Range("B8").Select
Selection.End(xlDown).Select
Range("C10").Select
ActiveSheet.Paste
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Range("C11").Select
End Sub
Avoid the use of .Select INTERESTING READ
Now You can use Autofilter for this or you can use the method that I am using below.
Let's say your worksheet looks like this
Logic:
Loop through the cell in column A and use DateDiff to check if the date is greater than 45 or not.
Once we find the range, we don't copy it to the end in the loop but store it in temp range. We copy the range at the end of the code. This way, your code will run faster.
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, OutputRow As Long
Dim copyRng As Range
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get LatRow in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
OutputRow = lRow + 1
'~~> Loop through the cells
For i = 1 To lRow
If DateDiff("d", .Range("B" & i).Value, Date) > 45 Then
If copyRng Is Nothing Then
Set copyRng = .Range("A" & i & ":B" & i)
Else
Set copyRng = Union(copyRng, .Range("A" & i & ":B" & i))
End If
End If
Next i
'~~> Copy the expired records in one go
If Not copyRng Is Nothing Then copyRng.Copy .Range("A" & OutputRow)
End With
End Sub
Output:
And if you want to show Expired in Col C then use this
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, OutputRow As Long
Dim copyRng As Range
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get LatRow in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
OutputRow = lRow + 1
'~~> Loop through the cells
For i = 1 To lRow
If DateDiff("d", .Range("B" & i).Value, Date) > 45 Then
If copyRng Is Nothing Then
Set copyRng = .Range("A" & i & ":B" & i)
Else
Set copyRng = Union(copyRng, .Range("A" & i & ":B" & i))
End If
End If
Next i
'~~> Copy the expired records in one go
If Not copyRng Is Nothing Then
copyRng.Copy .Range("A" & OutputRow)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("C" & OutputRow & ":C" & lRow).Value = "Expired"
End If
End With
End Sub
Output:
EDIT (FOLLOWUP FROM COMMENTS)
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, OutputRow As Long
Dim copyRng As Range
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get LatRow in Col B
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
OutputRow = lRow + 1
'~~> Loop through the cells
For i = 15 To lRow
If DateDiff("d", .Range("E" & i).Value, Date) > 45 Then
If copyRng Is Nothing Then
Set copyRng = .Range("B" & i & ":I" & i)
Else
Set copyRng = Union(copyRng, .Range("B" & i & ":I" & i))
End If
End If
Next i
'~~> Copy the expired records in one go
If Not copyRng Is Nothing Then
copyRng.Copy .Range("B" & OutputRow)
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("I" & OutputRow & ":I" & lRow).Value = "Expired"
End If
End With
End Sub