Hello i have a sub that copies from every sheet in the wb to a sheet named "Table", the sheets are structured with multiple tables and i need to copy the first table from the top, without the headers and aggregate every table contain from the sheets into sheet "Table":
Sub TableCopy()
Dim ws1 As Worksheet, _
LR1 As Long, _
LR2 As Long
Application.ScreenUpdating = False
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name <> "Table" Then
LR1 = Sheets("Table").Range("H" & Rows.Count).End(xlUp).Row + 1
LR2 = ws1.Range("B8", Range("B8").End(xlDown)).Rows.Count - 1
ws1.Range("A:S" & LR2).Copy Destination:=Sheets("Table").Range("A" & LR1)
End If
Next ws1
Application.ScreenUpdating = True
End Sub
I'm getting
Method Range of 'object' worksheet failed
I just can't get the grasp of it, can you help me? thx
Two fixes:
Sub TableCopy()
Dim ws1 As Worksheet, _
LR1 As Long, _
LR2 As Long
Application.ScreenUpdating = False
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name <> "Table" Then
LR1 = Sheets("Table").Range("H" & Sheets("Table").Rows.Count).End(xlUp).Row + 1 'Fix 1 (qualified the rows.count)
LR2 = ws1.Range("B8", Range("B8").End(xlDown)).Rows.Count - 1
ws1.Range("A2:S" & LR2).Copy Destination:=Sheets("Table").Range("A" & LR1) 'Fix 2 (added a # for starting row in copy range, assume row 1 is header)
End If
Next ws1
Application.ScreenUpdating = True
End Sub
Sub TableCopy()
Dim ws1 As Worksheet, _
LR1 As Long, _
LR2 As Long
Application.ScreenUpdating = False
For Each ws1 In ActiveWorkbook.Worksheets
If ws1.Name <> "Table" Then
LR1 = Worksheets("Table").Cells(Worksheets("Table").Rows.count, "H").End(xlUp).row + 1
LR2 = ws1.Cells(ws1.Rows.count, "B").End(xlUp).row - 9
ws1.Range("A2:S" & LR2).Copy Destination:=Worksheets("Table").Range("A" & LR1)
End If
Next ws1
Application.ScreenUpdating = True
End Sub
Related
I have two sheets. Sheet1 (PasteHere) has a long list of values in col B. For example:
100000
100100
100800
100801
200501
etc
Sheet2 (Landing) has a list I need to filter by. For example:
100000
100801
The end result is that I would like the values in sheet 1 to be filtered by the values in sheet 2. I am thinking I could name the range in sheet 2 and then filter by it, but it is not working. Here is the code I have so far. I am naming the range "CustList"
Sub FilterList()
Sheets("Landing").Select
Dim LastRow1 As Long
LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
Range("B15:B" & LastRow1).Select
ActiveWorkbook.Names.Add Name:="CustList", RefersToR1C1:= _
"=Landing!R15C2:R[" & LastRow1 & "]C2"
Range("E16").Select
Dim vCrit As Variant
Dim rngCrit As Range
Set rngOrders = Sheets("PasteHere").Range("$A$1").CurrentRegion
Set rngCrit = Sheets("Landing").Range("CustList")
vCrit = rngCrit.Value
Sheets("PasteHere").Select
rngOrders.AutoFilter _
Field:=2, _
Criteria1:=Application.Transpose(vCrit), _
Operator:=xlFilterValues
End Sub
Use the below code.
Dim LastRow1, LastRow2, iLoop
Sheets("Landing").Select
LastRow1 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
ReDim xarr(LastRow1 - 14)
For iLoop = 1 To LastRow1 - 14
xarr(iLoop) = ActiveSheet.Range("B" & iLoop)
Next
Sheets("PasteHere").Select
LastRow2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$" & LastRow2).AutoFilter Field:=1, Criteria1:=xarr, Operator:=xlFilterValues
Try this code:
Option Explicit
Sub FilterRange()
'declaration of variables
Dim filterBy As Variant, toFilter As Variant, lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, k As Long, _
filtered As Variant, ws1 As Worksheet, ws2 As Worksheet, flag As Boolean
k = 1
flag = True
'set references to worksheets, it's good to use them when you deal with more than one worksheet
'REMEMBER: use your own sheet name and change ranges I used (I used A column)
Set ws1 = Worksheets("Arkusz1")
Set ws2 = Worksheets("Arkusz2")
'set the ranges (storethem as arrays): to filter and one to filter by
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
toFilter = ws1.Range("A1:A" & lastRow1).Value2
'clear range, we will write here filtered values
ws1.Range("A1:A" & lastRow1).Clear
lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
filterBy = ws2.Range("A1:A" & lastRow1).Value2
'here you loop thorugh arrays, checking if one element is in the other array
'if it isn't, write this value to cell on ws1
For i = 1 To lastRow1
flag = True
For j = 1 To lastRow2
If toFilter(i, 1) = filterBy(j, 1) Then
flag = False
Exit For
End If
Next
If flag Then
ws1.Cells(k, 1).Value = toFilter(i, 1)
k = k + 1
End If
Next
End Sub
I am trying to copy data from workbook1 and pasting to workbook2 as per there valves if the valve is not same as previous than create a new sheet in the workbook and start pasting valve in the new sheet and do until did not find blank row in workbook1.
Sub icopy()
Dim LastRow As Long, Limit2 As Long, c As Long, d As Long, erow As Long
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, wb As Workbook,
wb1 As Workbook
If Is_WorkBook_Open("test.xlsx") Then
Set wb = Workbooks("test.xlsx")
Else
Set wb = Workbooks.Open("D:\Data\test.xlsx")
End If
Set sh1 = wb.Sheets("Sheet1")
LastRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row
'wb.Close
MsgBox LastRow
For i = 2 To LastRow
If sh1.Cells(i, 1) = sh1.Cells(i + 1, 1) Then
If (i = 2) Then
Set wb1 = Workbooks.Open("D:\Data\Data1.xlsx")
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sh1.Cells(2, 1)
Set sh2 = wb1.ActiveSheet.Name
End If
sh1.Range(Cells(i, 1), Cells(i, 3)).Copy
erow = sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'sh2.Cells(erow, 1).Select
sh2.Cells(erow, 3).Paste
sh2.Paste
ActiveWorkbook.Save
Else
MsgBox i
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sh1.Cells(i + 1, 1)
End If
Next i
'erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'ActiveSheet.Cells(erow, 1).Select
' ActiveSheet.Paste
'ActiveWorkbook.Save
'ActiveWorkbook.Close
'Application.CutCopyMode = False
End Sub
Function Is_WorkBook_Open(ByVal strWorkbookName As String) As Boolean
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(strWorkbookName)
If Err Then
Is_WorkBook_Open = False
Else
Is_WorkBook_Open = True
End If
End Function
since I understand your valve data are adjacent (i.e. all same valve data are within one block of adjacent rows), you could consider the following:
Option Explicit
Sub icopy()
Dim sh1 As Worksheet, sh2 As Worksheet, wb1 As Workbook
Dim iRow As Long
If Is_WorkBook_Open("test.xlsx") Then
Set sh1 = Workbooks("test.xlsx").Sheets("Sheet1")
Else
Set sh1 = Workbooks.Open("D:\Data\test.xlsx").Sheets("Sheet1")
End If
Set wb1 = Workbooks.Open("D:\Data\Data1.xlsx") ' open your target workbook
With sh1
iRow = 2
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
Do While iRow <= .Rows.Count
.AutoFilter field:=1, Criteria1:=.Cells(iRow, 1).Value
wb1.Sheets.Add(After:=wb1.Sheets(wb1.Sheets.Count)).name = .Cells(iRow, 1).Text
With .Resize(, 3).SpecialCells(xlCellTypeVisible)
.copy Destination:=wb1.Sheets(.Cells(iRow, 1).Text).Range("a1")
iRow = .Areas(.Areas.Count).Rows(.Areas(.Areas.Count).Rows.Count).row + 1
End With
Loop
End With
.AutoFilterMode = False
End With
End Sub
I know this question is as old as time, but I am trying to copy data thats on an excel file, to another, based on multiple criteria.
The destination is called "Test.xlsm" and the source is called "Data.xlsx"
The idea would be for the code to identify the rows that have the text (1,3,D) on the column A, and copy the entire row to the Sheet1 on the destination Test.xlsm
The first row on Test.xlsm has a header so it has to be left alone when copying data to that sheet.
Both files have the destination and source info on sheets called "Sheet1" as default.
I found this code, but i cant adapt it to use a different worksheet for the source, though any code that does the goal is fine.
Sub Copy()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
If Range("A" & r).Value = "1" Or Range("A" & r).Value = "3" Or Range("A" & r).Value = "D" Then
Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
Application.ScreenUpdating = True
End Sub
You'll want to use Workbooks as well, since you are using separate ones, and then set the sheets like the example you provided.
For example:
Dim wkbk1 as Workbook, wkbk2 as Workbook, ws1 as WorkSheet, ws2 as Worksheet
Set wkbk1 = Workbooks.open("C:\path\to\Data.xlsx")
Set wkbk2 = Workbooks.open("C:\path\to\Test.xlsm")
Set ws1 = wkbk1.Sheets("Sheet1")
Set ws2 = wkbk2.Sheets("Sheet1")
From there you can use and modify the code you have.
edit: included OP's workbook and sheet names.
Try this edit or note where I've made edits based on the points in comments - I think this should do well!
Sub CopyThings()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Application.Workbooks("Data").Worksheets("Sheet1")
Set ws2 = Application.Workbooks("Test").WorkSheets("Sheet1")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
If ws1.Range("A" & r).Value = "1" Or ws1.Range("A" & r).Value = "3" Or ws1.Range("A" & r).Value = "D" Then
ws1.Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
Application.ScreenUpdating = True
End Sub
I would like to copy data from sheet INV_LEDGERSinto Ready to uploadsheet, but the sheet Ready to upload already contains some data and therefore I want to loop through the column A in Ready to upload sheet until it will find the blank cell and then paste the data from INV_LEDGERS.
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet
Dim LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If ws.Range("A" & i) > "" And ws1.Range("A" & i + 1) = "" Then
ws.Range("A" & i & ":AE" & i).Copy
ws1.Range("A" & i + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Else
End If
Next
End Sub
It doesnt show the error msg anymore, but now it copies the data from INV_LEDGERSfrom the row, where data on sheet Ready to upload ends. I mean, that if data on Ready to upload has the end on row 82, the code will take the data from INV_LEDGERS from 82. row, so basically there are missing 81 rows.
Could you advise me, please?
Thanks a lot!
Given the comments from braX, here is my code.
Since you are always starting on the 4th row of the ledger data, you can just copy the entire section and then paste it to your last row + 1 on your upload sheet.
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet
Dim LastRow, LRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A4:AE" & LastRow).Copy
ws1.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End Sub
Couple things... have used a With statement, and instead of copy/paste, I'm just making ws1.Value=ws.Value:
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet, LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
With ws
LastRow = .Cells( .Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If .Range("A" & i) > "" And ws1.Range("A" & i + 1) = "" Then
ws1.Range("A" & i + 1 & ":AE" & i + 1).Value = .Range("A" & i & ":AE" & i).Value
End If
Next
End With
End Sub
Edit
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet, LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
With ws
LastRow = .Cells( .Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If IsEmpty(ws1.Range("A" & i + 1)) Then
ws1.Range("A" & i + 1 & ":AE" & i + 1).Value = .Range("A" & i & ":AE" & i).Value
End If
Next
End With
End Sub
I have an Excel sheet with names as one column and their working hours as values in next column.
I want to copy names with values greater than 40 to new sheet without any blanks in columns. The new sheet should have both names and the working hours; any text in the values column should be ignored.
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
For i = 1 To lastrow1
If sh1.Cells(i, "F").Value > 20 Then
sh2.Range("A" & i).Value = sh1.Cells(i, "F").Value
End If
Next i
End Sub
I would recommend using AutoFilter to copy and paste as it is faster than looping. See the example below.
My Assumptions
Original Data is in Sheet 1 as shown the snapshot below
You want the output in Sheet 2 as shown the snapshot below
CODE
I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long
'~~> Set the input sheet
Set wsI = Sheets("Sheet1"): Set wsO = Sheets("Sheet2")
'~~> Clear Sheet 2 for output
wsO.Cells.ClearContents
With wsI
'~~> Remove any existing filter
.AutoFilterMode = False
'~~> Find last row in Sheet1
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Filter Col B for values > 40
With .Range("A1:B" & lRow)
.AutoFilter Field:=2, Criteria1:=">40"
'~~> Copy the filtered range to Sheet2
.SpecialCells(xlCellTypeVisible).Copy wsO.Range("A1")
End With
'~~> Remove any existing filter
.AutoFilterMode = False
End With
'~~> Inform user
MsgBox "Done"
End Sub
SNAPSHOT
Try rhis
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
j = 1
For i = 1 To lastrow1
If Val(sh1.Cells(i, "F").Value) > 20 Then
sh2.Range("A" & j).Value = sh1.Cells(i, "F").Value
j = j + 1
End If
Next i
End Sub