I'm trying to copy all rows with data from one sheet into another.
I get a runtime error at the selection.paste line.
Sub move_rows2()
Dim i As Integer, countSheets As Integer, rowCount As Integer
countSheets = Application.Sheets.Count
For i = 1 To countSheets
Worksheets(i + 1).Select
Range("A" & Rows.Count).End(xlUp).Select
rowCount = ActiveCell.Row
Rows("1:" & rowCount).Select
Range("A" & rowCount).Activate
Selection.Copy
Worksheets(1).Select
Range("A" & Rows.Count).End(xlUp).Select
Selection.Offset(2, 0).Select
Selection.Paste
Next i
End Sub
Without the select/activate, and using an explicit workbook reference.
Dim i As Long, wb As Workbook
Set wb = ActiveWorkbook
For i = 2 To wb.Sheets.Count
With wb.Sheets(i)
.Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Copy _
wb.Sheets(1).Cells(.Rows.Count, 1).End(xlUp).Offset(2, 0)
End With
Next i
Related
I've created a macro that splits data in a table based on a column in to new sheets. When it's been split it changes the headers from 1,2,3 and so on to what size that corresponds to in a table in the workbook. Last it removes any additional columns that i don't want to be in the new sheets that was created.
For me the Macro works perfectly every time but when my colleague runs it it doesn't work as expected. First it got the same data in both sheets and secondly it have removed more columns than it should. I have shared it with 2 other colleagues and for one it works as expected but the second one has the same issue as the first colleague i shared it with.
Below is the macro i'm using, i've separated the 3 parts of the macros with "-" so it's easier to see what is what.
Does anyone have an idea of why it gives 2 different results for different users?
Just to add we got the same version of Excel.
Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
Dim xWS As Worksheet
Application.ScreenUpdating = False
On Error Resume Next
Worksheets(3).Activate 'Tab to split
Set xTRg = Range("1:1") 'Headers to include
Set xVRg = Range("H:H") 'Split by column
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then 'Checking so the worksheet doesn't exist
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet" 'Adds a worksheet with a name xTRgWs_Sheet
Else
Sheets("xTRgWs_Sheet").Delete 'If the worksheet exists delete it
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet" 'Adds a worksheet with a name xTRgWs_Sheet
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
xWS.Name = myarr(i) & ""
Else
xWS.Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
xWS.Paste Destination:=xWS.Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
-----------------------------------------------------------------------------------------
'Remove columns to make the data look nice
Dim lColumn As Long
Dim iCntr As Long
Dim wb, y, f As Integer
wb = ThisWorkbook.Sheets.Count
y = 0
f = 0
lColumn = 220
For y = wb To 4 Step -1
Worksheets(y).Activate
'Remove the buy index column
If Range("A1") = "BUY INDEX" Then
Columns("A").Delete
End If
-----------------------------------------------------------------------------------------
'Change size index to size description
Range("I1").Select
f = Range(Selection, Selection.End(xlToRight)).Columns.Count
Range(Cells(1, 9), Cells(1, f)).Offset(0, f).Select
Selection.Formula = _
"=IFERROR(VLOOKUP($G2&""-""&I1,'Purchase grids'!$D:$I,6,0),"""")"
Selection.Copy
Range("I1").PasteSpecial Paste:=xlPasteValues
'Remove excess columns without values
For iCntr = lColumn To 1 Step -1
If Trim(Cells(2, iCntr)) = “” Then
Columns(iCntr).Delete
End If
Next
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
Worksheets(2).Activate
Application.ScreenUpdating = True
End Sub
I'm trying to get my spreadsheet to automatically generate new names and sheets based on a data dump. I currently have the sheet working so that it will generate the name and sheet for each row of data, but I cannot get it to populate the sheet using that row.
There is a specific section of code that I cannot get to work:
For Each Nm In shNAMES
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm) ' <<< This line here
End If
Next Nm
I know that the issue is using Nm to reference the cell (it's returning "OP01" which is the cell contents), but I'm trying to not add another workaround. I've tried using other functions to do similar after the Nm loop has finished, but can't seem to get those working either. Surely the answer has to be simple and I'm just missing something?
Option Explicit
Sub SheetsFromTemplate()
Application.ScreenUpdating = False
Rows("1:8").EntireRow.Delete
Call CreateLONums
Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long
With ThisWorkbook
Set wsTEMP = .Sheets("Template")
wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
Set wsMASTER = .Sheets("Creation Page")
Set wsINDEX = .Sheets("Local Options")
With Sheets("Creation Page").Columns("A")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
End With
Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
For Each Nm In shNAMES
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm)
End If
Next Nm
wsINDEX.Activate
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden
End With
Worksheets("Creation Page").Delete
Worksheets("Template").Delete
Call CreateLinksToAllSheets
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub CreateLONums()
Dim firstrow As Long, lastrow As Long, rowcount As Integer
Columns("A:A").Insert Shift:=xlToRight
With Sheets("Creation Page").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
For rowcount = firstrow To firstrow + 9
Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
Next rowcount
For rowcount = firstrow + 9 To lastrow
Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
Next rowcount
End With
End Sub
Appreciate any insight available.
Managed to work it out, took way longer than it should have -.-'
I borrowed a bit of Function code to reference the number from column A, then used that to reference the cells that I wanted.
For Each Nm In shNAMES
rownum = GetDigits(Nm) 'This bit here is calling the function
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value `This is utilising rownum to reference the cells
End If
Next Nm
Function code can be found here: How to find numbers from a string?
Entire code section in case it is useful to someone in future:
Option Explicit
Sub SheetsFromTemplate()
Application.ScreenUpdating = False
Rows("1:8").EntireRow.Delete
Call CreateLONums
Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long, rownum As Integer
With ThisWorkbook
Set wsTEMP = .Sheets("Template")
wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
Set wsMASTER = .Sheets("Creation Page")
Set wsINDEX = .Sheets("Local Options")
With Sheets("Creation Page").Columns("A")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Available"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
End With
Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
For Each Nm In shNAMES
rownum = GetDigits(Nm)
If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
wsTEMP.Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = CStr(Nm.Text)
ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value
End If
Next Nm
wsINDEX.Activate
If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden
End With
Worksheets("Template").Move after:=Worksheets(Worksheets.Count)
Worksheets("Creation Page").Move after:=Worksheets(Worksheets.Count)
Call CreateLinksToAllSheets
Call UpdateIndexTechSpec
Call UpdateIndexOptDescription
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub CreateLONums()
Dim firstrow As Long, lastrow As Long, rowcount As Integer
Columns("A:A").Insert Shift:=xlToRight
With Sheets("Creation Page").Columns("B")
If WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "Sorry: no data"
Else
With .SpecialCells(xlCellTypeConstants)
firstrow = .Areas(1).Row
lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
End With
End If
For rowcount = firstrow To firstrow + 9
Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
Next rowcount
For rowcount = firstrow + 9 To lastrow
Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
Next rowcount
End With
End Sub
Sub CreateLinksToAllSheets()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 1).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sh.Name & "'" & "!A1", TextToDisplay:=sh.Name
ActiveCell.Offset(1, 0).Select
End If
Next sh
Call UpdateIndexTechSpec
Call UpdateIndexOptDescription
End Sub
Sub UpdateIndexTechSpec()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 2).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Value = sh.Range("B2").Value
ActiveCell.Offset(1, 0).Select
End If
Next sh
End Sub
Sub UpdateIndexOptDescription()
Dim sh As Worksheet
Dim cell As Range
Sheets("Local Options").Activate
ActiveSheet.Cells(10, 3).Select
For Each sh In ActiveWorkbook.Worksheets
If ActiveSheet.Name <> sh.Name Then
ActiveCell.Value = sh.Range("D2").Value
ActiveCell.Offset(1, 0).Select
End If
Next sh
End Sub
Function GetDigits(ByVal s As String) As String
Dim char As String
Dim i As Integer
GetDigits = ""
For i = 1 To Len(s)
char = Mid(s, i, 1)
If char >= "0" And char <= "9" Then
GetDigits = GetDigits + char
End If
Next i
End Function
My error comes at the definition of LR. It is error object required 424. Anyone knows the problem?
Sub
Dim LR As Long
Dim FLR As Long
LR = wb.Sheets("DTH&TPD Claims List").Cells(Row.Count, 2).End(xlUp).Row
FLR = wb.Sheets("DTH&TPD Claims List").Cells(Row.Count, 1).End(xlUp).Row + 1
wb.Sheets("DTH&TPD Claims List").Cells(FLR, 1).Value = "19"
wb.Sheets("DTH&TPD Claims List").Cells(FLR, 1).Select
Selection.AutoFill Destination:=Range("A" & FLR & ":" & "A" & LR)
End Sub
After Rectification:
There is Error in Selection.Autofill in the Below code now.
Sub tst()
Dim LR As Long
Dim FLR As Long
Dim wb As Workbook
Set wb = ActiveWorkbook 'assuming you want your code to run in
With wb.Sheets("DTH&TPD Claims List")
LR = .Cells(.Rows.Count, 2).End(xlUp).row
FLR = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Cells(FLR, 1).Value = "19"
.Cells(FLR, 1).Select
Msgbox LR & " " & FLR
Selection.AutoFill Destination:=.Range("A" & FLR & ":A" & LR)
End With
End Sub
Problems:
No declaration of wb
Wrong formula row.count
Try this:
Sub tst()
Dim LR As Long
Dim FLR As Long
Dim wb As Workbook
Set wb = ActiveWorkbook 'assuming you want your code to run in
With wb.Sheets("DTH&TPD Claims List")
LR = .Cells(.Rows.Count, 2).End(xlUp).row
FLR = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Cells(FLR, 1).Value = "19"
.Cells(FLR, 1).Select
Msgbox LR & " " & FLR
Selection.AutoFill Destination:=.Range("A" & FLR & ":A" & LR)
End With
End Sub
I have cleaned up your code as well.
New to forum and very new to VBA. I'm trying to consolidate data off hundreds of forms I get every month. I have to grab a few extra fields off the forms (names, dates, stores) and fill down alongside the other columns. I've run into the error of when there is only one row of data and can't autofill. I've tried to work around this with an IF, Then, Else. What happens is after it hits a file that has that one row, it will not do the autofill on any subsequent files with more than one. It almost works.
Code:
Sub test()
Dim FolderPath As String
Dim FileName As String
Dim wb As Excel.Workbook
Dim Erow
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
FolderPath = "C:\Users\Test\"
FileName = Dir(FolderPath & "*.xlsx")
Do While FileName <> ""
Workbooks.Open (FolderPath & FileName)
Range("B10").Select
Selection.Copy
Range("K17").Select
ActiveSheet.Paste
Range("J9").Select
Application.CutCopyMode = False
Selection.Copy
Range("L17").Select
ActiveSheet.Paste
Range("J11").Select
Selection.Copy
Range("M17").Select
ActiveSheet.Paste
Dim lastRow As Long
If lastRow > 17 Then
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("K17").AutoFill Destination:=Range("K17:K" & lastRow),
Type:=xlFillCopy
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("L17").AutoFill Destination:=Range("L17:L" & lastRow),
Type:=xlFillCopy
lastRow = Range("D" & Rows.Count).End(xlUp).Row
Range("M17").AutoFill Destination:=Range("M17:M" & lastRow),
Type:=xlFillCopy
Else
ActiveWorkbook.Save
Range("A17:M200").Copy
ActiveWorkbook.Close
End If
Erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(Erow, 1), Cells(Erow, 13))
FileName = Dir
Loop
End Sub
Here is a screenshot of what happens after the "one row" file.
Error After One Row, Auto Fill stops
The problem arises from having the calculation for the lastrow within the IF statement. The lastrow is only recalculates when lastRow > 17 from the previous workbook.
Calculate lastrow before the IF statement, so that you're looking at the lastrow of the current workbook each time.
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