By some reason every time I run this code it hides all the data on the new sheet.
The row heights are set to 0.
I have to use the mouse to pull on the row height to make the last cell visible then from there I can click on a cell and "get up" to the data.
How can I fix this? It's very annoying.
Is it something with my code or do I need to set the row height after pasting data like this?
NumMax = NumMax + 1 'there is more code above that sets NumMax
ThisWorkbook.Activate
ThisWorkbook.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "XCFIL_" & NumMax
ThisWorkbook.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "Resultat_" & NumMax
Sheets("XCFIL").Activate
Cells.Copy
Sheets("XCFIL_" & NumMax).Activate
Range("A1").PasteSpecial xlPasteAll
Range("A1").Select ' a try to get up in the sheet, but it does not work
EDIT: Code panes:
Per the chat, a quick solution is:
'Other option is to simply copy/paste the sheet
NumMax = NumMax + 1 'there is more code above that sets NumMax
With ThisWorkbook
.Sheets("XCFIL").Copy After:=.Sheets(.Sheets.Count)
ActiveSheet.Name = "XCFIL_" & NumMax
End With
But, I was working on the below, which may work as well.
Sub t()
Dim originWS As Worksheet, destWS As Worksheet
Dim NumMax As Long
NumMax = NumMax + 1 'there is more code above that sets NumMax
With ThisWorkbook
Set originWS = .Sheets("XCFIL")
Set destWS = .Sheets.Add(After:=.Sheets(.Sheets.Count))
destWS.Name = "XCFIL_" & NumMax
End With
Dim copyRng As Range
Dim lastCol As Long, lastRow As Long
With originWS
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set copyRng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol)) 'assuming your data starts in A1
End With
destWS.Range(destWS.Cells(1, 1), destWS.Cells(lastRow, lastCol)).Value = _
copyRng.Value
End Sub
And as a note, it's always a good idea to avoid using .Select/.Activate.
Also, this doesn't get to the very quirky issue of the rows hiding on PasteSpecial. ...but oh well, if it works, it works.
Related
I've encountered a problem run-time Error '424' object required.
This is the solution i've acquired from my previous post, after spending some time to troubleshoot, i still can't solve it. Thanks to #rawrplus for the solution and I am still learning Excel vba.
Link: Excel VBA Cutting rows from workbook1 and paste it in workbook2
Option Explicit
Private Sub table_to_table()
'Declaration
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb1 = Workbooks.Open("C:\Documents and Settings\lye.yan.nian\My Documents\testingmacro2.xlsx")
Set wb2 = Workbooks.Open("C:\Documents and Settings\lye.yan.nian\My Documents\testingmacro3.xlsx")
Set ws1 = wb1.Sheets("Test2")
Set ws2 = wb2.Sheets("Test1")
Dim res_lr As Long
Dim lr2 As Long
lr2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row
MsgBox lr2 /* Testing is done as i can get this value */
Dim r As Range, ary
Set r = ws1.Application.Range(Cells(1, 2), Cells(1, 6)) /* Tested working as i can get this value too*/
ary = Application.Transpose(Application.Transpose(r.Value))
MsgBox Join(ary, " ")
Dim copyrange As Range
Dim i As Long /* This is declared */
For i = 2 To lr2
MsgBox i /* i did some testing on this and removed the below code */
Set copyrange = ws2.Application.Range(Cells(i, 2), Cells(i, 6)).Copy /* This is the part where i got the error i can't figure out why*/
res_lr = ws2.Cells(Rows.Count, 8).End(xlUp).Row
ws2.Range(Cells(res_lr, 8), Cells(res_lr, 12)).PasteSpecial xlPasteValues
Set copyrange = ws1.Application.Range(Cells(i, 2), Cells(i, 6)).Copy
ws2.Range(Cells(res_lr + 1, 8), Cells(res_lr + 1, 12)).PasteSpecial xlPasteValues
Next i
wb1.Close
End Sub
Set copyrange = ws2.Application.Range(Cells(i, 2), Cells(i, 6)).Copy
Range.Copy does not return a Range object reference that you can assign to a Range object variable. It's a member method that takes the contents of a range, and copies it into the clipboard.
Your copyrange isn't the result of the .Copy operation, it's the result of a ws2.Application.Range(...) call... which is malformed.
This might fix it1:
Set copyrange = ws2.Application.Range(Cells(i, 2), Cells(i, 6))
copyrange.Copy
....and this is what you probably meant to be doing:
Set copyrange = ws2.Range(ws2.Cells(i, 2), ws2.Cells(i, 6))
copyrange.Copy
1 it's bad code, because you have an explicit Worksheet reference (ws2), and from there you go to Application to grab whatever worksheet is currently active, and work off that - so you think you're working off ws2 when in reality you're working off whatever ActiveSheet currently happens to be. Same with the unqualified Cells calls, which implicitly refer to Application.ActiveSheet.Cells.
Try adding the word set on the line where it throws error.
Example: set x = 'something
Apologies in advance as I'm sure this is a simple question, and there's lots of similar answers out there, but I haven't been able to leverage them into a working solution.
My situation is I have an Excel file with 28 tabs. Each Sheet has data in the exact same format in range A1:N10000. Note though that some of the cells in each tab are blank. This holds true across every tab. I would like to have all 28 tabs merged into one new Sheet call Combined.
I have been trying to leverage this Macro:
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
Obviously I've encountered problems running this and the resulting data only has a few values pasted instead of the expected ~280,000 rows (28 tabs, 10k rows each). I suspect one of the reasons is because there are blank cells in the tabs, so this Macro isn't reading the data as I intend it to. How can I modify it just to copy A1:N10000 in each tab and paste each to the Combined tab? Also, will I hit issues with trying to populate a sheet with 280,000 rows?
Thank you!
David
CurrentRegion will not copy everything you want if there are blank cells, as you suspected. Also, it's preferable to avoid using Select - since you don't really need to select the cells before copying - and On Error Resume Next - this doesn't handle errors at all, it ignores them.
Option Explicit
Sub Combine()
Dim i As Integer
Dim combinedWs As Worksheet, ws As Worksheet
Dim copyRng As Range
Dim lastRow As Long
' Add combined worksheet and populate headers
Set combinedWs = Worksheets.Add(Before:=Sheets(1))
combinedWs.Name = "Combined"
Sheets(2).Rows(1).Copy combinedWs.Rows(1)
' Loop through rest of Sheets
For i = 2 To Sheets.Count
Set ws = Sheets(i)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set copyRng = Range(.Cells(2, 1), .Cells(lastRow, "N"))
copyRng.Copy combinedWs.Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
Next i
End Sub
If you want to copy a specific, hard-coded range, replace the code inside With ws... End With.
Set copyRng = Range(.Cells(2, 1), .Cells(10000, 14))
copyRng.Copy combinedWs.Cells(2, 1).Offset((i-2)*copyRng.Rows.Count)
A bit of a hack on the last line: for each iteration of i you are offsetting by the number of rows in copyRng. You start in combinedWs.Cells(2, 1), or A2. On the first iteration, i - 2 = 0, so there is no offset. On subsequent iterations, you offset 9999, 19998, and so on.
You can try the below code:
Sub Combine()
Dim cmbSheet, ws As Worksheet
Dim tmpIndex As Double
Set cmbSheet = ThisWorkbook.Worksheets.Add
cmbSheet.Name = "Combined"
tmpIndex = 0
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Combined" Then
If tmpIndex = 0 Then
cmbSheet.Cells(1, 1) = "Sheet Name"
ws.Range("A1:N1").Copy Destination:=cmbSheet.Cells(1, 2)
End If
ws.Range("A2:N10000").Copy Destination:=cmbSheet.Cells((tmpIndex * 10000) + 2 - tmpIndex, 2)
cmbSheet.Cells((tmpIndex * 10000) + 2, 1).Value = ws.Name
tmpIndex = tmpIndex + 1
End If
Next ws
End Sub
I hope you are all well.
I am trying to use the below code to add orders of different products together. but only products with a value greater than 0 in column D. Unfortunately though the code for some reason is only copying the first row of the range, even though there are other rows which meet the criteria. can anyone help?
Sub ADDTOORDERS()
Dim Sh As Worksheet, C As Worksheet, Last As Long
Set Sh = Sheets("Menu")
Set C = Sheets("LensOrder")
With Sh
Last = .Cells(Rows.Count, 2).End(xlUp).Row
.Range("B7:D" & Last).AutoFilter Field:=2, Criteria1:=">0", Operator:=xlAnd
.Range("B7:D" & Last).SpecialCells(xlCellTypeVisible).Copy
C.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Sheets("Menu").Range("C3").Select
.Range("B7:D" & Last).AutoFilter
End With
End Sub
Made only 1 change. check this. last row thing.
Sub ADDTOORDERS()
Dim Sh As Worksheet, C As Worksheet, Last As Long
Set Sh = Sheets("Menu")
Set C = Sheets("LensOrder")
With Sh
.Range("B7:D" & Last).AutoFilter Field:=2, Criteria1:=">0", Operator:=xlAnd
Last = .range("B500000").end(xlup).row
.Range("B7:D" & Last).SpecialCells(xlCellTypeVisible).Copy
C.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Sheets("Menu").Range("C3").Select
.Range("B7:D" & Last).AutoFilter
End With
End Sub
The problem with your code is that your are trying to copy the resulting range, however that range has several areas, thus it's only copying the first area.
One of the methods to work in this situation is to pass the resulted range into an array then to post the array into the desired range.
This solution assumes the header is at row 6
Try the code below:
Option Base 1 'This must be at the top of the module
Sub Add_Orders()
Dim wshSrc As Worksheet, wshTrg As Worksheet
Dim rCpy As Range, aCpy() As Variant
Dim rArea As Range, rRow As Range
Dim lRowLst As Long, lRow As Long
With ThisWorkbook
Set wshSrc = .Worksheets("Menu")
Set wshTrg = .Worksheets("LensOrder")
End With
lRowLst = wshSrc.Cells(wshSrc.Rows.Count, 2).End(xlUp).Row
'' With wshSrc.Range("B7:D" & lRowLst) 'The filter should always include the header - Replacing this line
With wshSrc.Range("B6:D" & lRowLst) 'With this line
ReDim Preserve aCpy(.Rows.Count)
.AutoFilter Field:=3, Criteria1:=">0"
Set rCpy = .Rows(1).Offset(1).Resize(-1 + .Rows.Count).SpecialCells(xlCellTypeVisible) 'Use the offset and resize to exclude the header
End With
For Each rArea In rCpy.Areas
For Each rRow In rArea.Rows
lRow = 1 + lRow
aCpy(lRow) = rRow.Value2
Next: Next
ReDim Preserve aCpy(lRow)
aCpy = WorksheetFunction.Index(aCpy, 0, 0)
With wshTrg.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Cells(1).Resize(UBound(aCpy), UBound(aCpy, 2)).Value = aCpy
End With
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
For Each...Next Statement,
Option keyword,
Range Object (Excel),
Variables & Constants,
With Statement,
I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With
I want the code to paste the entire column if the headers Match. As of now it is only pasting values from Row(1). Thanks a lot. If there are any other questions I will be commenting back quickly. I took out all the Dims and whatnot.
Sub sample()
Set sh1 = Sheets("Dec Demand")
Set sh2 = Sheets("List")
Set sh3 = Sheets("Results")
With sh2
Set rngLookupValues = .Range("J2", .Range("J" & .Rows.Count).End(xlUp))
End With
Debug.Print rngLookupValues.Address
With sh1
Set rngHeaders = .Range("A1", .Range("A1").End(xlToRight))
End With
Debug.Print rngHeaders.Address
For Each cValue In rngLookupValues
lngColumnToCopy = WorksheetFunction.Match(cValue, rngHeaders, 0)
Debug.Print lngColumnToCopy
With sh1
Set rngCellsToCopy = .Range(.Cells(1, lngColumnToCopy), .Cells(Rows.Count, lngColumnToCopy).End(xlUp)) ' HERE i want to have a copy entire column
End With
Debug.Print rngCellsToCopy.Address
With sh3
lngCurFirstEmptyColumn = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
End With
Debug.Print lngCurFirstEmptyColumn
sh3.Cells(1, lngCurFirstEmptyColumn).Resize(rngCellsToCopy.Rows.Count) = rngCellsToCopy
Next cValue
With sh3.Range("A1")
If Len(.Value) < 1 Then
.EntireColumn.Delete
End If
End With
End Sub
You need to change
sh3.Cells(1, lngCurFirstEmptyColumn).Resize(rngCellsToCopy.Rows.Count) = rngCellsToCopy
to
sh3.Cells(1, lngCurFirstEmptyColumn).Resize(rngCellsToCopy.Rows.Count).Value = rngCellsToCopy.Value
or
rngCellsToCopy.Copy sh3.Cells(1, lngCurFirstEmptyColumn)
(don't know why, but your statement doesn't copy anything, but adding .Value fixes the problem)
' HERE i want to have a copy entire column
If you really need to copy EntireColumn (which make your code very slow), follow next steps
1) change
Set rngCellsToCopy = .Range(.Cells(1, lngColumnToCopy), .Cells(Rows.Count, lngColumnToCopy).End(xlUp))
to
Set rngCellsToCopy = .Cells(1, lngColumnToCopy).EntireColumn
2) and then change
sh3.Cells(1, lngCurFirstEmptyColumn).Resize(rngCellsToCopy.Rows.Count) = rngCellsToCopy
to
sh3.Cells(1, lngCurFirstEmptyColumn).EntireColumn.Value = rngCellsToCopy.Value
or you could use rngCellsToCopy.Copy sh3.Cells(1, lngCurFirstEmptyColumn) as well.
And one little note: use forgot to add period . before Rows.Count in the line Set rngCellsToCopy = .Range(.Cells(1, lngColumnToCopy), .Cells(Rows.Count, lngColumnToCopy).End(xlUp))