Excel VBA: Copy cells from multiple sheets to a single sheet - excel

I am pretty new to VBA and am trying to automate a process at work where I need to extract select cells from an array of 6 sheets and consolidate them in another sheet. The code I have works, but is kinda "clunky" - I am using the excel copy and paste functions, but can't seem to find a good solution away from the copy-and-paste function. And when I try to add a paste special function, I get an 1004 error. Would love advice on optimising this!
For each sheet to be copied, cells are marked in the first column with "1", "0" or left blank - if the cells are "1" or "0", I copy the other cells in the row to the consolidated sheet. There are some gaps in between rows, so I opted to use a For-Loop instead of a Do-While statement.
I've attached the code as follows:
Sub TEST()
Dim i As Integer 'copying row counter for each sheet to be copied
Dim j As Integer 'pasting row counter in consolidated sheet
Dim cal(1 To 6) As String 'copied sheetname
cal(1) = "Picks"
cal(2) = "Eats"
cal(3) = "Night Out"
cal(4) = "Active"
cal(5) = "Family"
cal(6) = "Arts"
Dim x As Integer
Dim y As Integer 'column for date
Dim z As Integer 'max row to run till
y = 1 'column checked in each sheet where condition for copying is met
z = 300 'number of rows to check in each sheet
j = 1
For x = 1 To 6
For i = 1 To z
If Sheets(cal(x)).Cells(i, y) = "0" Or Sheets(cal(x)).Cells(i, y) = "1" Then
Sheets(cal(x)).Select
Range(Sheets(cal(x)).Cells(i, 2), Sheets(cal(x)).Cells(i, 10)).Select
Selection.Copy
Application.Goto ActiveWorkbook.Sheets(Consolidated).Cells(j, 1)
ActiveSheet.Paste
Else
j = j - 1
End If
j = j + 1
Next i
Next x
End Sub
Again I would love to optimise this code, using another method instead of copy-and-paste. Also I tried:
Application.Goto ActiveWorkbook.Sheets(Consolidated).Cells(j, 1)
ActiveSheet.PasteSpecial Operation:=xlPasteValues
Which resulted in a 1004 error. Would love to know what went wrong.

You're getting the error because you're attempting to paste into the activesheet instead of into a range on the activesheet, and because you have the wrong argument for the PasteSpecial method.
This will work, although it's not what you want to do: (see CopyWithoutClipboard further below for a better alternative)
Sub PasteIntoGoto()
Sheets("sheet1").Range("A1").Copy
Application.Goto ActiveWorkbook.Sheets("Sheet3").Cells(1, 1)
ActiveSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End Sub
Note the range inserted in between ActiveSheet and PasteSpecial and Paste:= instead of Operation:=.
You're right in wanting to optimize your code. Maybe the most important guideline in Excel VBA development is to never select anything, which can cause all kinds of problems. In your first example, you are using .Select explicitly, and in the second example, .GoTo is effectively doing the same thing.
Rather than selecting a sheet, copying a range, selecting another sheet, and pasting into another range, you can write a copy of the data to the target range (either on the same sheet or on another one) like this:
Sub CopyWithoutClipboard()
Sheets("sheet1").Range("A1").Copy Sheets("sheet2").Range("A1")
End Sub
Obviously you can use variables in place of the hard-coded objects in the snippet above.

Related

VBA Copy value of merged cells to another sheet

I am aware that there are many questions like this one in this forum. Yet, none of them gives satisfying reply.
I need a macro that will copy values from 3 cells from various sheets (all in the same Excel file): E6 (actually it is a merged cell containing columns EFG), E(FG)5 and E21. Then pastes those values into new sheet into columns A, B and C. There are 2 problems that do not let me solve this issue with traditional copy cell value code or answers in other threads in this forum:
There are 3 cells merged.
The number of worksheets might differ for different period of times, and they might change their names as well.
This is the code that I have found for another similar problem:
Sub CopyToMaster()
ShtCount = ActiveWorkbook.Sheets.Count
For i = 2 To ShtCount
Worksheets(i).Activate
Range("E6").Select
Selection.Copy
Sheets("Master").Activate
'Required after first paste to shift active cell down one
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(0, -3).Select
Selection.PasteSpecial
Next i
End Sub
Source Data (This is source data, I where I marked with yellow 3 cells that values, I need to copy):
Needed result (Here is the expected outcome, where each from previous yellow marked cells should be pasted in respective column):
Thx for your help.
Please, test the next (working) code. It should be faster than yours, not using clipboard. You must know that the value of a merged range is kept in its top left cell. So, having ranges with a single row, it is enough to try extracting the value of the first marge cells cell:
Sub CopyToMasterWorking()
Dim ws As Worksheet, wsM As Worksheet, lastR As Long, i As Long
Set wsM = Worksheets("Master")
wsM.UsedRange.Resize(wsM.UsedRange.rows.count - 1).Offset(1).ClearContents 'clear everything, except headers
For Each ws In ActiveWorkbook.Worksheets
If ws.name <> wsM.name Then
lastR = wsM.UsedRange.SpecialCells(xlCellTypeLastCell).row + 1
wsM.Range("A" & lastR).Value = ws.Range("E6").Value
wsM.Range("B" & lastR).Value = ws.Range("E5").Value
wsM.Range("C" & lastR).Value = ws.Range("E21").Value
wsM.Range("D" & lastR).Value = ws.name 'you may comment this line if not necessary...
End If
Next ws
End Sub
I thought that it would be good to have a little traceability, I mean to know from which sheet the data comes (per row). If you do not need it, you may comment last code line from iteration between sheets.
The code also clear everything in "Master" sheet, except the header, before starting processing. If you need to add at the end of existing data, you have to comment that line, too.
Please, send some feedback after testing it. If something not clear enough, do not hesitate to ask for clarification...
I think your only problem is copying merged-cell ranges, correct? This shows how to copy a merged-cell range to 1) same-sized range 2) single cell 3) different-sized range:
Option Explicit
Sub sub1()
Dim variant1
Cells.Delete
' define a merged-cell range and populate:
Range("b2:c3").MergeCells = True
Range("b2:c3") = " B2:C3 "
' to copy to a like-sized merged-cell range:
Range("b5:c6").MergeCells = True
Range("b2:c3").Copy Range("b5:c6")
' to copy to a single cell
variant1 = Range("b2:c3").Value
Range("b8").Value = variant1
' to copy to a different-sized merged-cell range:
Range("b10:d12").MergeCells = True
variant1 = Range("b2:c3").Value
Range("b10:d12").Value = variant1
End Sub

Is there a VBA code to select multiple (and varied totals of) columns from multiple worksheets to copy and paste into a new worksheet

I am trying to copy multiple columns from multiple worksheets into a new worksheet in Excel using a VBA Macro.
I have already created the worksheet, and I want to paste specific columns one after another in that worksheet.
I would like to copy from each worksheet all columns including and beyond a certain column, in all worksheets including and from Column F.
I have written a piece of code that selects the appropriate data and loops correctly.
However, i get a "run-time error 1004", when the loop hits a worksheet where I am copying only one column.
I know this is because of the choice of my code. However, I don't know how to solve the problem.
The problem is that my code selects a range to the end of the worksheet when there is only one column being selected. This creates a copied area too big to paste in the new worksheet.
Dim i As Integer
i = 1
Do While i <= Worksheets.Count - 1
Worksheets(i).Select
'Select, Copy and Paste Data
RangeFromF1
Selection.Copy
Worksheets("Combined").Select
Range("X1").Select
Selection.End(xlToLeft).Select
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
i = i + 1
Loop
End Sub
Public Sub RangeFromF1()
Range("F1", Range("F1").End(xlDown).End(xlToRight)).Select
End Sub
Instead of going from column F to the right, try going from the last column to the left.
Public Sub RangeFromF1()
Range("F1", Cells(1, Columns.Count).End(xlToLeft).End(xlDown)).Select
End Sub
You might also want to get rid of all the Select stuff.
Sub CopyStuff()
Dim i As Long
i = 1
Do While i <= Worksheets.Count - 1
With Worksheets(i)
.Range("F1", .Cells(1, .Columns.Count).End(xlToLeft).End(xlDown)).Copy
Worksheets("Combined").Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Paste
i = i + 1
End With
Loop
End Sub
Before coming back to check for your answer noris, I figured out a way, to do as you suggested, with the following code:
Public Sub ReferenceSelection()
Dim startcell As Range
Set startcell = Range("A1").End(xlDown).End(xlToRight)
Range(startcell, ("F1")).Select
End Sub

How to copy and paste range instead of row?

I am putting together a basic inventory control system and I would like the columns with a time-stamp in the "Checked-Out" column to be pasted into a list on another worksheet. I have successfully copied the correct entire rows, but I would like this to just copy and paste the table rows instead because I have instructions listed in column A that are not relevant for the compiled list. I am new to VBA coding, thanks in advance!
I have named ranges for the two tables called "Inventory_List": Inventory!$I$3:$N$1048576 and "Checked_Out": CheckedOut!$B$3:$G$1048576 as the copy/paste ranges respectively.
Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long
endRow = 1000 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("N").Column).Value > 0 Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("CheckedOut").Select
Rows(pasteRowIndex + 5).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Inventory").Select
End If
Next r
End Sub
When I try to reference ranges instead of entire rows, I get "run-time error 1004" because my copy area and paste area aren't the same size, but I am a bit confused because my ranges seem to be the same size. I am pretty sure this is because I am adding the ranges to the incorrect portion of the code.
Copying and pasting of Excel ranges is quite standard, if you take into account 2 things:
Refer to the ranges correctly with the upper left cell and the lower right cell;
Always, refer to the Parent worksheet.
In the code below, the upper left cell and the lower right cells of the copied and pasted ranges are like this:
.Range(.Cells(count, 1), .Cells(count, "C"))
copyTo.Range(copyTo.Cells(count, 1), copyTo.Cells(count, "C"))
The parent worksheets are always referred. With with for the copyFrom and with explicit writing for copyTo.
Sub TestMe()
Dim copyFrom As Worksheet
Dim copyTo As Worksheet
Set copyFrom = Worksheets(1) 'Or better write the name - Worksheets("CheckedOut")
Set copyTo = Worksheets(2)
Dim count As Long
For count = 1 To 30
With copyFrom
If .Cells("N", count) > 0 Then
.Range(.Cells(count, 1), .Cells(count, "C")).Copy Destination:=copyTo.Range(copyTo.Cells(count, 1), copyTo.Cells(count, "C"))
End If
End With
Next
End Sub
Last, but not least - this is a must read for VBA - How to avoid using Select in Excel VBA

VBA to remove part of the same cell's content on multiple sheets

I need to remove the first half of a formula on multiple sheets throughout a workbook. Four specific cells per sheet (F308, F315, F322, F329) need to have just the first part of the formula removed.
The formula is: ='Project Input - John1'!$D$954*'Project Input - John1'!$D$952
The major catch here is each cells formula on each sheet, while extremely similar, is different. Each sheet referred to is different on each sheet and each referring cell is different in every cell.
I don't want to change the unique second part, just remove the first part: 'Project Input - John1'!$D$954*. or everything before (and including) *.
Is it possible to create a workbook formula to do this where I only have to run it once? If not, is it possible to do it sheet by sheet with a standard reference like, "This sheet"? Thanks!
Edit:
I have tried to record a macro but it applied the last part of the formula from the cell I recorded it in
I tried this VBA:
Sub test()
tx = Split(Cells(6, 315), "4")
For i = LBound(tx) To UBound(tx)
Cells(1, 2) = tx(i)
Next
End Sub
and this:
Dim ichar As Integer ichar = InStr(1, cl.Value, afterString, vbTextCompare)
cl = Left(cl.Value, ichar + Len(afterString) -1)
End Sub
Sub test() Call removetextbefore("*", Sheet11.Cell(f308))
End Sub
I got a compile error
I'm trying to find code that works and have scoured the sites, but nothing is seeming to work.
You may be able to do something like this, using the Split method:
Sub editFormulas()
Dim R As Range
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
With WS
For Each R In Union(.Cells(308, 6), .Cells(315, 6), .Cells(322, 6), .Cells(329, 6))
R.Formula = "=" & Split(R.Formula, "*")(1)
Next R
End With
Next WS
End Sub

Excel: Paste Special > Adding a "blank" cell with VBA

I have a large data set that I'm working with in excel. About 1000+ columns and close to 1 million rows.
My issue is that many of my numbers are formatted as text. To resolve this, I've been using the copy paste > add technique, adding a blank cell.
My problem is that I'm trying to macro this functionality, but I can't figure out how to add a blank cell.
I tried to get crafty and have the macro create a new row, do the add, then delete that row. But, I can't seem to get that to work either.
Anyone have a solution?
Instead of selecting the entire range, you need to select only the cells with values in them. I would suggest the Special Cells function:
Highlight the cell with the #1 in it and COPY that cell
Highlight a column of cells to convert
Press F5 > Goto > Special > Constants (you may have to play with the options here to get only the cells you want)
OK (Now only the cells with values are selected)
Now select Paste Special > Multiply
Using VBA you can conditionally convert the target values to doubles (or another type of your choosing).
Tested example below assumes:
you are working with Sheet1 in ActiveWorkbook
numbers stored as text in column A (1)
converted values to appear in column B (2)
An aside: It's probably always a good idea save your work before running VBA. Cheers, and happy coding.
Option Explicit
Sub convert_to_dbl()
Dim r As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets(1)
For r = 1 To FindLastRow(ws)
With ws
If .Cells(r, 1).Value <> "" Then
.Cells(r, 2).Value = CDbl(.Cells(r, 1).Value)
End If
End With
Next r
End Sub
Function FindLastRow(ws As Worksheet)
Dim LastRow As Long
If WorksheetFunction.CountA(Cells) > 0 Then
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
FindLastRow = LastRow
End Function
The following code does what I was looking for.
Sub psAdd()
Dim x As Range 'Just a blank cell for variable
Dim z As Range 'Selection to work with
Set z = Cells
Set x = Range("A65536").End(xlUp).Offset(1)
If x <> "" Then
Exit Sub
Else
x.Copy
z.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
Application.CutCopyMode = False 'Kill copy mode
End If
x.ClearContents 'Back to normal
End Sub

Resources