copy and pasting area not the same size? - excel

Dim lastrow&, lastCol&, myarray As Range
lastrow = Range("A1").End(xlDown).Row
lastCol = Range("XX1").End(xlToLeft).Column
Set myarray = Range("A1").Resize(lastrow, lastCol)
Range("A1", myarray).Select
So i added the above code to recognise the last column and last row and copy the array
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.WindowState = xlNormal
Windows("Ex-Pakistan Calculator Final.xlsm").Activate
Sheets("MRG").Select
'has to find the last row by itself
Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select
ActiveSheet.Paste
Getting an error on the last line "activesheet.paste" saying copy and pasting area isn't the same size, try selecting one cell. enter image description here
Thing is, "Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select" does only select one cell, so I don't see the issue.

Following is an ideal way to copy and paste using range selection. You can change this code as per your requirement.
Sub CopyPaste()
Dim selectRange As range
Dim lastrow As Integer
Application.CutCopyMode = False
Sheets("Sheet1").Activate
lastrow = range("A1").End(xlDown).Row
Set selectRange = range("A1:A" & lastrow)
selectRange.Copy
Sheets("Sheet2").range("B1:B" & lastrow).PasteSpecial xlPasteAll
End Sub

Congrats on starting to use VBA. There's several things in your code that could use improvement. You want to avoid using select (a common beginner task). You also don't even need to move around your sheet, or even use copy/paste.
However, see below where I've broken up your code with some statements to stop and check where you're at. I think this will accomplish what you want, but also help you gain a better grasp of what you're doing (it's always a battle getting started!)
Keep battling.
Sub adfa()
Const turnOnStops As Boolean = True 'change to true or false to review code
Dim WS_Pull As Worksheet:
Set WS_Pull = ActiveSheet 'better to define this with actual sheet name
Dim lastrow As Long:
lastrow = WS_Pull.Cells(Rows.Count, 1).End(xlUp).Row 'this assumes column a has the bottom row and no rows hidden
If turnOnStops Then
Debug.Print "Lastrow is " & lastrow
Stop
End If
Dim lastcol As Long:
lastcol = WS_Pull.Cells(1, Columns.Count).End(xlToLeft).Column 'same assumptions but with columns on row 1 instead of columna a
If turnOnStops Then
Debug.Print "lastcol is " & lastcol
Stop
End If
Dim myarray As Range:
Set myarray = WS_Pull.Range("A1").Resize(lastrow, lastcol) ' I'm not sure what you're trying to do here.
If turnOnStops Then
Dim theAnswer As Long
theAnswer = MsgBox("The address of myArray is " & myarray.Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
Dim WS_paste As Worksheet: Set WS_paste = Sheets("MRG") 'it would be better to use the SHEET (shown in the VBA project)
WS_Pull.Range("A1", myarray).Copy '<--- what are trying to copy.
If turnOnStops Then
theAnswer = MsgBox("The area copied was " & WS_Pull.Range("A1", myarray).Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
If turnOnStops Then
theAnswer = MsgBox("The area you are going to paste to is " & _
WS_paste.Cells(1, Rows.Count).End(xlUp).Offset(2, 0).Address & " stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
End Sub

Related

Remove blank rows when print

error im getting this error when using your code
Dim answer As Integer
answer = MsgBox("Äðóêóâàòè?", vbYesNo + vbQuestion, "Äðóê")
If answer = vbYes Then
ActiveSheet.PageSetup.PrintArea = "A1:N27"
ActiveWindow.SelectedSheets.PrintOut
Else
'End
End If
End Sub
need the macro to print areas that are field within range A1:N27 and delete blank can someone solve it?
Due to my fault there where three problems that FaneDuru has found with my workbook that his code didn't worked with my workbook
The rows to be hide/deleted are not empty. They contains formulas...
The result of formula on column D:D is "".
The worksheet in discussion is protected, but without a password
Try the next code, please. It will hide the rows being empty on the range B:L, print and then un-hide them. The updated code is done according to your last specifications (there are formulas in the 'empty' rows, in column D:D the formula result is "" and the worksheet is protected, but without a password):
Sub testRemoveRowsPrintAreaSet()
Dim sh As Worksheet, lastRow As Long, rngDel As Range, i As Long
Set sh = ActiveSheet
lastRow = sh.Range("C" & Rows.Count).End(xlUp).Row
For i = 9 To lastRow
Debug.Print WorksheetFunction.CountBlank(sh.Range("B" & i & ":L" & i))
If WorksheetFunction.CountBlank(sh.Range("B" & i & ":L" & i)) = 10 Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("M" & i)
Else
Set rngDel = Union(rngDel, sh.Range("M" & i))
End If
End If
Next i
If Not rngDel Is Nothing Then
sh.Unprotect
rngDel.EntireRow.Hidden = True
End If
sh.PageSetup.PrintArea = "A1:N" & lastRow
ActiveWindow.SelectedSheets.PrintOut
rngDel.EntireRow.Hidden = False
sh.Protect
End Sub
Please, confirm that it work as you need.

Copy and paste data from one sheet to multiple where range matches sheet names

I have an API call that pulls data relating to 34 individual sites. Each site has a varying number of assets within it, each with a unique identifier.
I am trying to write a macro that will copy and paste the data for specific sites into their own individual worksheet within the file. The basic concept of this I am familiar with but I am struggling with the ranges I need to specify.
So basically, I need the macro to work its way down Column A of the sheet called Raw Data and identify any rows where the Site name (Value in column A) matches one of the Sheet names. It should then copy the Rows from A to H with that site name and paste into the respective site sheet in rows A to H.
The values in Column A will always match one of the other sheets in the workbook.
Example image that might help explain a bit better:
Apologies in advance if my explanation is not very clear. I have very limited experience using macros so I am not sure if my way of explaining what I want to achieve is understandable or if at all possible.
I am very keen to learn however and any guidance you fine folk could offer would be very much appreciated.
Welcome!
Try this one
Function ChkSheet(SheetName As String) As Boolean
For i = 1 To Worksheets.Count
If Worksheets(i).Name = SheetName Then
ChkSheet = True
Exit Function
End If
Next
ChkSheet = False
End Function
Sub test()
Dim i, j, k As Long
Dim wsRaw As Worksheet
Dim Aux As String
Set wsRaw = Worksheets("Raw Data")
For i = 1 To wsRaw.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
If ChkSheet(wsRaw.Cells(i, 1).Value2) Then
Aux = wsRaw.Cells(i, 1).Value2
k = Worksheets(Aux).Range("A:A").SpecialCells(xlCellTypeLastCell).Row + 1
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
Else
Worksheets.Add.Name = wsRaw.Cells(i, 1).Value2
Aux = wsRaw.Cells(i, 1).Value2
k = 2
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
End If
Next
End Sub
So the Function ChkSheet will check if the sheet exist (you don´t need to create them) and the procedure test will follow all the items that you have in your "Raw Data" worksheet and it will copy to the last used row of every sheet.
And please, even for a newbie, google, read, get some information and when you get stacked, ask for help. This forum is not for giving solutions with not effort.
Good morning all,
David, thanks very much for your help with this. I really didn't want you to think I was trying to get someone to give me the answer and I had tried a few other things before asking the question, but I neglected to show any evidence of my workings. Rookie mistake and I apologise for this.
Having done a bit more research online and with a good dollop of help from a much more experienced colleague I have got the below code using advance filter which works perfectly for what I need.
I thought I would share it here in case it is of any use to others in the future.
Option Explicit
Dim RawDataCol As String
Dim ListCol As String
Dim AdvRng As String
Dim RawDataRng As String
Dim SiteAbrRng As String
Dim ShiftCols As String
Private Sub SetParameters()
'Cell Address where RawData is pasted to each of the site sheets
RawDataCol = "A2"
'Column where the Unique List is cleared and pasted
ListCol = "L"
'Advanced Filter Range
AdvRng = "A1:K2"
'Pasted Raw Data Columns on each sheet
RawDataRng = "A2:K"
'Site Abr gets pasted to the address during loop
SiteAbrRng = "A2"
'Range that gets deleted after pasting Raw Data to each sheet
ShiftCols = "A2:K2"
End Sub
Sub CopyDataToSheets()
On Error GoTo ErrorHandler
AppSettings (True)
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim wbk As Workbook
Dim sht_RawData As Worksheet, sht_target As Worksheet, sht_AdvancedFilter As Worksheet, sht_TurbineData As Worksheet
Dim tbl_RawData As ListObject
Dim LastRow1 As Long, LastRow2 As Long, UniqueListCount As Long
Dim MyArr As Variant
Dim ArrTest As Boolean
Dim x As Long, AdvRowNo As Long
Set wbk = ThisWorkbook
SetParameters
Set sht_RawData = wbk.Worksheets("Raw Data")
Set sht_AdvancedFilter = wbk.Worksheets("Advanced Filter")
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_RawData = sht_RawData.ListObjects("_00")
'clear unqie list of SiteAbr
With sht_TurbineData
LastRow1 = .Cells(Rows.Count, 12).End(xlUp).Row
If LastRow1 > 1 Then
'sht_TurbineData.Range("L1:L" & LastRow1).ClearContents
sht_TurbineData.Range(ListCol & 1 & ":" & ListCol & LastRow1).ClearContents
End If
End With
'Copy Unqiue list of SiteAbr to Turbie Data Sheet
tbl_RawData.Range.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=sht_TurbineData.Range(ListCol & 1), _
Unique:=True
LastRow1 = sht_TurbineData.Cells(Rows.Count, sht_TurbineData.Range(ListCol & 1).Column).End(xlUp).Row
'Sort Unique List
sht_TurbineData.Range("L1:L" & LastRow1).Sort _
Key1:=sht_TurbineData.Range("L1"), _
Order1:=xlAscending, _
Header:=xlYes
'Load unique site Abr to array
With sht_TurbineData
'MyArr = Application.Transpose(.Range("L2:L" & LastRow1))
MyArr = Application.Transpose(.Range(ListCol & 2 & ":" & ListCol & LastRow1))
UniqueListCount = LastRow1 - 1
End With
'Test Array conditions for 0 items or 1 item
ArrTest = IsArray(MyArr)
If UniqueListCount = 1 Then
MyArr = Array(MyArr)
ElseIf UniqueListCount = 0 Then
GoTo ExitSub
End If
For x = LBound(MyArr) To UBound(MyArr)
Set sht_target = wbk.Worksheets(MyArr(x))
With sht_target
'Find the last non blank row of the target paste sheet
LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
'Clear contents if the Last Row is not the header row
If LastRow2 > 1 Then
.Range(RawDataRng & LastRow2).ClearContents
End If
sht_AdvancedFilter.Range(SiteAbrRng) = MyArr(x)
'Filter Source Data and Copy to Target Sheet
tbl_RawData.Range.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=sht_AdvancedFilter.Range(AdvRng), _
CopyToRange:=.Range(RawDataCol), _
Unique:=False
'Remove the first row as this contains the headers
.Range(ShiftCols).Delete xlShiftUp
End With
Next x
ExitSub:
SecondsElapsed = Round(Timer - StartTime, 3)
AppSettings (False)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
ErrorHandler:
MsgBox (Err.Number & vbNewLine & Err.Description)
GoTo ExitSub
End Sub
Sub ClearAllSheets()
Dim tbl_SiteList As ListObject
Dim wbk As Workbook
Dim sht_target As Worksheet, sht_TurbineData As Worksheet
Dim MyArray As Variant
Dim x As Long, LastRow As Long
Set wbk = ThisWorkbook
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_SiteList = sht_TurbineData.ListObjects("SiteList")
SetParameters
MyArray = Application.Transpose(tbl_SiteList.DataBodyRange)
For x = LBound(MyArray) To UBound(MyArray)
Set sht_target = wbk.Worksheets(MyArray(x))
LastRow = sht_target.Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
sht_target.Range("A2:K" & LastRow).ClearContents
End If
Next x
End Sub
Private Sub AppSettings(Opt As Boolean)
If Opt = True Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ElseIf Opt = False Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Thanks again to all who answered and especially to you David. Although I have only used the basic principles from what you offered, it was extremely useful to help me understand what I needed to do in order to get the data to copy into the correct sheets.
Many thanks,
MrChrisP

Archive data from "sheet1" to next blank row of "sheet2"

I have code to archive data from "sheet1" to "sheet2". It overwrites existing data in the "sheet2" rows from the previous archive exercise.
How do I have it seek the next blank row vs. overwriting existing data?
I have two header rows so it should commence with row 3.
Option Explicit
Sub Archive()
Dim lr As Long, I As Long, rowsArchived As Long
Dim unionRange As Range
Sheets("sheet1").Unprotect Password:="xxxxxx"
Application.ScreenUpdating = False
With Sheets("sheet1")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For I = 3 To lr 'sheets all have headers that are 2 rows
If .Range("AB" & I) = "No" Then
If (unionRange Is Nothing) Then
Set unionRange = .Range(I & ":" & I)
Else
Set unionRange = Union(unionRange, .Range(I & ":" & I))
End If
End If
Next I
End With
rowsArchived = 0
If (Not (unionRange Is Nothing)) Then
For I = 1 To unionRange.Areas.Count
rowsArchived = rowsArchived + unionRange.Areas(I).Rows.Count
Next I
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
unionRange.EntireRow.Delete
End If
Sheets("sheet2").Protect Password:="xxxxxx"
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Operation Completed. Total Rows Archived: " & rowsArchived
End Sub
Change
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
... to,
with worksheets("sheet2")
unionRange.Copy _
Destination:=.Cells(.rows.count, 1).end(xlup).offset(1, 0)
end with
This is like starting at the bottom row of the worksheet (e.g. A1048576) and tapping [ctrl+[↑] then selecting the cell directly below it.
The With ... End With statement isn't absolutely necessary but it shortens the code line enough to see it all without scolling across. unionRange has been definied by parent worksheet and cell range so there is no ambiguity here.
I'd propose the following "refactoring"
Option Explicit
Sub Archive()
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = Sheets("sheet1")
Set sht2 = Sheets("sheet2")
sht1.Unprotect Password:="xxxxxx"
With sht1.Columns("AB").SpecialCells(xlCellTypeConstants).Offset(, 1) '<== change the offset as per your need to point to whatever free column you may have
.FormulaR1C1 = "=if(RC[-1]=""NO"","""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
.EntireRow.Copy Destination:=sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Offset(1, 0)
MsgBox "Operation Completed. Total Rows Archived: " & .Cells.Count
End With
.ClearContents
End With
sht2.Protect Password:="xxxxxx"
End Sub
just choose a "free" column in "Sheet1" to be used as a helper one and that'll be cleared before exiting macro. In the above code I assumed it's one column to the right of "AB"
The following approach worked for me! I'm using a button to trigger macro.
Every time it takes the last row and append it to new sheet like a history. Actually you can make a loop for every value inside your sheet.
Sub copyProcess()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim source_last_row As Long 'last master sheet row
source_last_row = 0
source_last_row = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Set copySheet = Worksheets("master")
Set pasteSheet = Worksheets("alpha")
copySheet.Range("A" & source_last_row, "C" & source_last_row).copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

VBA Selection.Formula returning "False" instead of "N/A"

I am using VBA to run a set of data against five "rule" columns stored in another sheet in the workbook. Put simply, I seem to have code which works, but the VBA use of Selection.Formula = returns "False" when an cell formula would return #N/A or #VALUE. It's critical that I get the error values because it tells the user something different than "False". False should mean that column C (see picture of calculation tab below) doesn't pass the rule. The error values mean that either column B is not found with VLookup in the Rules column or the rule was written incorrectly.
Here's what I have so far:
Sub Build_Formulas_v2()
Application.Calculation = xlManual
Range("a2", Range("a65536").End(xlUp)).Offset(0, 6).Select
Selection.Value = _
Evaluate("(""=""&SUBSTITUTE(VLOOKUP(B2,'Logic Statements'!A:E,4,FALSE),""ZZZ"",""c""&ROW()))")
End Sub
Any help would be tremendously appreciated - my VBA knowledge is still growing and is too basic to understand what I'm up against.
I believe you are using Excel 2003. You should never hard code values like A65536. You can get undesirable results in xl2007+ as they have 1048576 rows.
Is this what you are trying?
Sub Build_Formulas_v2()
Dim lRow As Long
Dim ws As Worksheet
Application.Calculation = xlManual
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A2:A" & lRow).Offset(0, 6).Formula = _
"=SUBSTITUTE(VLOOKUP(B2,'Logic Statements'!A:E,4,FALSE),""ZZZ"",""c""&ROW())"
'~~> Uncomment the below in case you want to replace formulas with values
'.Range("A2:A" & lRow).Offset(0, 6).Value = .Range("A2:A" & lRow).Offset(0, 6).Value
End With
End Sub
Or if you do not want to use .Offset, then you can directly address Column G
Sub Build_Formulas_v2()
Dim lRow As Long
Dim ws As Worksheet
Application.Calculation = xlManual
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("G2:G" & lRow).Formula = _
"=SUBSTITUTE(VLOOKUP(B2,'Logic Statements'!A:E,4,FALSE),""ZZZ"",""C""&ROW())"
'~~> Uncomment the below in case you want to replace formulas with values
'.Range("A2:A" & lRow).Offset(0, 6).Value = _
.Range("A2:A" & lRow).Offset(0, 6).Value
End With
End Sub

Moving rows based on column values

I need to scan through all of the rows in the "Master" worksheet, find any cells with the value "Shipped" in the column "Status", then cut and paste each entire row to another sheet. The pasted rows need to be placed after the last row also.
I found this post (pasted below) which I slightly modified to delete rows successfully. But I can not figure out how to move rows instead. Should I try an entirely new method?
Sub DeleteRows()
Dim rng As Range
Dim counter As Long, numRows as long
With ActiveSheet
Set rng = Application.Intersect(.UsedRange, .Range("C:C"))
End With
numRows = rng.Rows.Count
For counter = numRows to 1 Step -1
If Not rng.Cells(counter) Like "AA*" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
End Sub
I do not know VBA. I only kind of understand it because of my brief programming history. I hope that is okay and thank you for any help.
There's a couple of ways you could do it, can you add a filter to the top columns, filter by the value of 'Shipped'? Does it need to be copy and pasted into a new sheet?
It's not the most concise code but it might work
sub Shipped_filter()
dim wsSheet as worksheet
dim wsOutputSheet as worksheet
dim BottomRow as integer
Set wsSheet = worksheets("Sheet1") 'change to the sheet name
set wsOutputSheet = worksheets("Sheet2") 'change to the sheet name
'*****************************
'* Delete old data on Sheet2 *
'*****************************
wsoutputsheet.activate
Activesheet.cells.clearall
wsSheet.range("A1").select
selection.autofilter
BottomRow = wsSheet.range("A90000").end(xlup).row ' or another column you guarantee will always have a value
activesheet.range("$A$1:$Z$"&BottomRow).AutoFilter field:=1, Criteria1:="Shipped" ' change field to whatever column number Status is in
'********************************
'* Error trap in case no update *
'********************************
if activesheet.range("A90000").end(xlup).row = 1 then
msgbox("Nothing to ship")
exit sub
end if
wsSheet.range("A1:Z"&Bottomrow).select
selection.copy
wsOutputSheet.range("A1").select
selection.pastespecial Paste:=xlpastevalues
application.cutcopymode = false
msgbox('update complete')
end sub
I haven't tried it so it might need updating
I ended up combining the code I was originally using (found here) with an AutoFilter macro (found here). This is probably not the most efficient way but it works for now. If anyone knows how I can use only the For Loop or only the AutoFilter method that would be great. Here is my code. Any edits I should make?
Sub DeleteShipped()
Dim lastrow As Long
Dim rng As Range
Dim counter As Long, numRows As Long
With Sheets("Master")
'Check for any rows with shipped
If .Range("R:R").Find("Shipped", , xlValues, xlWhole, , , False) Is Nothing Then
MsgBox "No shipped plates found. ", , "No Rows Moved": Exit Sub
Else
Application.ScreenUpdating = False
'Copy and paste rows
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Worksheets("ShippedBackup").Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A1:U" & lastrow).AutoFilter field:=18, Criteria1:="Shipped"
.Range("A2:U" & lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("ShippedBackup").Range("A" & lastrow2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
.ShowAllData
'Delete rows with shipped status
Set rng = Application.Intersect(.UsedRange, .Range("R:R"))
numRows = rng.Rows.Count
For counter = numRows To 1 Step -1
If rng.Cells(counter) Like "Shipped" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
MsgBox "All shipped records have been moved to the ""ShippedBackup"" worksheet.", , "Backup Complete"
End If
End With
Hope it helps someone!

Resources