I am trying to autofill using a macro but it doesnt work... Will only fill H2 and I2 cells, the rest are blank. Whats wrong with my code?
Sub company()
Dim LastRow As Long
With Sheets("Combined")
LastRow = .Cells(Rows.Count, "H").End(xlUp).Row
.Range("H2:H" & LastRow).Value = 0
LastRow = .Cells(Rows.Count, "I").End(xlUp).Row
.Range("I2:I" & LastRow).Value = 1
End With
End Sub
Related
So When i run this macro, the A column will be filled with P's and the C column will be filled with 7's, just as I intended it to.
However I also needed the H and I columns to fill with 0's and 1's respectively.
However on the workbook, each worksheet will have the H and I columns unfilled. Only H2 and I2 will be filled. And in some worksheets the H2 and I2 will be the dates (1/0/1900),(1/1/1900) respectively. In other worksheets H2 and I2 will just have a 0 and 1, respectively.
Why is this happening? And why are some of the incorrect columns dates and others are numbers? How can this be fixed?
Dim i As Long
Dim LastRow As Long
For i = 1 To Worksheets.count
With Sheets(i)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A2:A" & LastRow).Value2 = "P"
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
.Range("C2:C" & LastRow).Value2 = "7"
LastRow = .Cells(Rows.Count, "H").End(xlUp).Row
.Range("H2:H" & LastRow).Value2 = "0"
LastRow = .Cells(Rows.Count, "I").End(xlUp).Row
.Range("I2:I" & LastRow).Value2 = "1"
End With
Next i
I guess that you have run the code twice and you do not see it changing any more. To see it adding more values every time you run it:
Sub Test()
Dim i As Long
Dim LastRow As Long
For i = 1 To Worksheets.Count
With Sheets(i)
.Columns("A:XFD").NumberFormat = "General"
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A2:A" & LastRow).Value2 = "P"
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row + 1
.Range("C2:C" & LastRow).Value2 = "7"
LastRow = .Cells(Rows.Count, "H").End(xlUp).Row + 1
.Range("H2:H" & LastRow).Value2 = "0"
LastRow = .Cells(Rows.Count, "I").End(xlUp).Row + 1
.Range("I2:I" & LastRow).Value2 = "1"
End With
Next i
End Sub
The problem with (1/0/1900) and (1/1/1900) is that these cells are formatted as date. And 0 is translated to 1/0/1900 and 1 is 1/1/1900. To fix this, in code above the cells are formatted as General with this line:
.Columns("A:XFD").NumberFormat = "General"
Basically, if in Sheet1 the cell in Column I is Not Blank, copy cells A, B, I and L to Sheet 2 on the next available blank row. Loop until end of rows on Sheet1.
I keep getting an error 9 or 450 code at the .Copy line.
I have connected the Module to a button on Sheet2. Could this be the reason?
Or should I use something different from the CopyPaste function?
This is the code I've been trying to get to work.
Option Explicit
Sub copyPositiveNotesData()
Dim erow As Long, lastrow As Long, i As Long
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheet1.Cells(i, "I") <> "" Then
Worksheets("Sheet1").Activate
' *** next line gives Err#450 "Wrong # of arguments or invalid property assignments" ****
Worksheets("Sheet1").Range(Cells(i, "A"), Cells(i, "B"), _
Cells(i, "I"), Cells(i, "L")).Copy
Worksheets("Sheet2").Activate
erow = WorkSheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2"). _
Range(Cells(i, "A"), Cells(i, "B"), Cells(i, "C"), Cells(i, "D"))
Worksheets("sheet1").Activate
End If
Next i
Application.CutCopyMode = False
End Sub
You need to use Application.Union to merge 4 cells in a row, something like the code below:
Full Modified Code
Option Explicit
Sub copyPositiveNotesData()
Dim erow As Long, lastrow As Long, i As Long
Dim RngCopy As Range
With Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Trim(.Cells(i, "I").Value) <> "" Then
Set RngCopy = Application.Union(.Range("A" & i), .Range("B" & i), .Range("I" & i), .Range("L" & i))
RngCopy.Copy ' copy the Union range
' get next empty row in "Sheet2"
erow = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' paste in the next empty row
Worksheets("Sheet2").Range("A" & erow).PasteSpecial xlPasteAll
End If
Next i
End With
Application.CutCopyMode = False
End Sub
You may try this (Not tested)
Option Explicit
Sub copyPositiveNotesData()
Intersect (Sheet1.Range("I2", Sheet1.Cells(.Rows.Count, "I").End(xlUp)).SpeciallCells(xlCellTypeConstants).EntireRow, Sheet1.Range("A:A", "B:B", "I:I", "L:L")).Copy Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub
Looks like the issue is that you are trying to copy multiple cells at once which isn't supported (try doing the same manually within the actual sheet). You need to copy either a single cell or a continuous range. You could either do 4 copy/pastes or could directly set the values in the destination sheet.
Try changing the copy/paste to the following (untested):
Sub copyPositiveNotesData()
Dim erow As Long, lastrow As Long, i As Long, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheet1.Cells(i, "I") <> "" Then
With ws2
.Range("A" & i).Value = ws1.Range("A" & i).Value
.Range("B" & i).Value = ws1.Range("B" & i).Value
.Range("I" & i).Value = ws1.Range("I" & i).Value
.Range("L" & i).Value = ws1.Range("L" & i).Value
End With
End If
Next i
End Sub
I want to copy all the rows from the Pipeline Report sheet that contain the text "AllScripts" in column T.
Then, I want to paste them onto another sheet starting from "A14" and go down.
Right now this code pastes them from "A2" but I need it to start from A14 and go down from there.
Sub extractAllscripts()
Dim myrange As Range
Dim lr as Long
Sheets("Pipeline Report").Select
Set myrange = Sheets("Pipeline Report").Range("T1", Range("T" & Rows.Count).End(xlUp))
For Each cell In myrange
If cell.Value = "Allscripts" Then
lr = Sheets("Macro Test Page").Range("T" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy Destination:=Sheets("Macro Test Page").Range("A" & lr + 1)
End If
Next cell
End Sub
This is a bad practice but as we don't know how your sheet is set up, then I would suggest this:
Sub extractAllscripts()
Dim myrange As Range
Dim lr as Long
Dim myoffset As Integer
Sheets("Pipeline Report").Select
Set myrange = Sheets("Pipeline Report").Range("T1", Range("T" & Rows.Count).End(xlUp))
myoffset = 13
For Each cell In myrange
If cell.Value = "Allscripts" Then
lr = Sheets("Macro Test Page").Range("T" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy Destination:=Sheets("Macro Test Page").Range("A" & lr + myoffset)
End If
myoffset = 1
Next cell
End Sub
Or another bad solution:
In your code substitute lr = Sheets("Macro Test Page").Range("T" & Rows.Count).End(xlUp).Row with lr = lr + 1 and define lr to be 13 outside of the loop and in the Range("A" & lr + 1) use lr instead of lr + 1.
I'm using a vlookup to pull a date from another sheet and I'm referencing a cell in the sheet that I want it to pull to. I want to drag the vlookup down but I can't figure out how to anchor the formula so it remains the same when I drag it down. Also I'm referencing cell "I2" and then I want the Vlookup then to reference "I3" and so on, but I'm not exactly sure how to code it. Any help would be appreciated! Here's my code:
Dim lastrow As Long
Dim StoreData As Range
lastrow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
Set StoreData = Sheets("List of Stores").Range("A2:C" & lastrow)
Sheets("SJ360 for Source 140").Select
Range("H1").Select
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
On Error GoTo myerrorhandler:
Dim x
With ThisWorkbook.Worksheets("SJ360 for Source 140")
x = Application.WorksheetFunction.VLookup(Range("I2"), StoreData, 3, False)
Range("H2").Value = x
End With
Dim FillFormula As Variant
x = x + 1
With ThisWorkbook.Sheets("SJ360 for Source 140")
Range("H2").Select
ActiveCell.Offset(x, 0).Select
FillFormula = "VLookup(x), StoreData, 3, False)"
.Range("H2:H&lastrow").Formula = FillFormula
.Range("H&lastrow").FillDown
End With
myerrorhandler:
If Err.Number = 1004 Then
MsgBox "Value not found"
End If
I tried to make it so x would be "I2" then "I3" etc but I didn't do it right.
Try this. When trying to fill the same formula down a range use R1C1:
Dim lastrow As Long
Dim StoreData As Range
lastrow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
Set StoreData = Sheets("List of Stores").Range("A2:C" & lastrow)
With Sheets("SJ360 for Source 140")
.Range("H1").EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
.Range("H2:H" & lastrow).FormulaR1C1 = "Vlookup(RC1," & StoreData.Address(1, 1, xlR1C1, True) & ",2,False)"
End With
If all you want is the value in the cells then use this:
Dim lastrow As Long
Dim StoreData As Range
lastrow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row
Set StoreData = Sheets("List of Stores").Range("A2:C" & lastrow)
With Sheets("SJ360 for Source 140")
.Range("H1").EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
.Range("H2:H" & lastrow).Value = .Evaluate("INDEX(Vlookup(I2:I" & lastrow & "," & StoreData.Address(1, 1,,True) & ",2,False),)")
End With
The below code works great for copying an entire row, how do I make it so I only copy over the first column.
I have tried altering range with no success? Condition is in J, the only column to copy should be 1st one.
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cell.EntireRow.Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Many thanks!
try
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cells(cell.row,1).Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cell.End(xlToLeft).Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Just switch EntireRow to EntireColumn, it is as simple as that! ;)
Dim rCell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each rCell In Sheets(1).Range("J1:J" & lastRow)
If rcell.Value = 1 Then
rcell.EntireColumn.Copy Sheets(5).Cells(1, i)
i = i + 1
End If
Next rCell