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
Related
Essentially, I have data in three columns and a model on a separate tab. The data tab has 1,000 rows of data, and each entry will be run through the model, with results being pasted into the fourth column.
Here's what one iteration would look like, but I need it to loop through every row.
Worksheets("Data").Range("E2:G2").Copy _
Worksheets("Model").Range("B4:D4").PasteSpecial Paste:=xlPasteValues
Calculate
Worksheets("Model").Range("C120").Copy_
Worksheets("Data").Range("H2").PasteSpecial Paste:=xlPasteValues
Worksheets("Model").Range("C121").Copy_
Worksheets("Data").Range("I2").PasteSpecial Paste:=xlPasteValues
Worksheets("Model").Range("C122").Copy_
Worksheets("Data").Range("J2").PasteSpecial Paste:=xlPasteValues
Then we'd copy the next row of data from the Data tab (i.e., range E3:G3).
This seems like a classic loop scenario, but I don't know how to write it in VBA.
You can do this on a range, I see two ways you can do it, using a copy and paste or simply replicating a transposed version of the data:
'Copy and paste method
Worksheets("Model").Range("C120:C" & range("C" & rows.count).end(xlup).row).Copy 'Using the .end(xlup) will find the last row of data without looping until blank.
Worksheets("Data").Range("H2").PasteSpecial xlPasteValues,,,True 'The True here is what tells the pastespecial to transpose
'Transpose method
Worksheets("Data").Range("H2:J2").Value = application.transpose(Worksheets("Model").range("C120:C122"))
Each have their advantage, the Copy and Paste method is easier because you don't need to know the end column so it works easier for a dynamic range, the transpose method doesn't use the clipboard so is less impact on your system.
The better method code wise would be the transpose method.
You can then set up a simple For Next loop to run through as many data ranges as you want.
Dim DataRow As Long, MyDat As Worksheet, MyModel As Worksheet
Set MyDat = Worksheets("Data")
Set MyModel = Worksheet("Model")
For DataRow = 2 To MyDat.Range("E" & Rows.Count).End(xlUp).Row
MyModel.Range("B4:D4").Value = MyDat.Range("E" & DataRow & ":G" & DataRow).value
Calculate
MyDat.Range("H" & DataRow & ":J" & DataRow).Value = Application.Transpose(MyModel.Range("C120:C122"))
Next
This is a simple loop that finds the last row in "Data" and uses it for the loop defined in "Model".
The expected result of this is that the loop will begin at row 120 and continue until the last row in "Data", copying data from C120 through to C(lRow) and pasting it into the "Data" sheet.
Sub test()
' declare your variables so vba knows what it is working with
Dim lRow, i As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim srcws As Worksheet: Set srcws = wb.Worksheets("Data")
Dim destws As Worksheet: Set destws = wb.Worksheets("Model")
' find the last row in Data
lRow = srcws.Cells(srcws.Rows.Count, 1).End(xlUp).Row
' iterate from 120 to the last row found above
For i = 120 To lRow
' copy /paste the data
srcws.cells(1, 3).Copy Destination:=destws.cells(2, 7 + i)
Next i
End Sub
Best way is to use the cells-function, where the first argument is the row and the second is the column. Since you want to inrement the source to copy from by one row at a time but increment the paste destination by one column by a time, this method will be suitable.
In addition, try to not use "copy-paste", focus on setting the value for a cell by referring to a the value attribute from the source to copy. Each time you copy and then paste into the destination, you will need an additional memory cell, resulting in a much longer elapsed time if you are working with a large range to copy.
The code below should do the job.
Sub CopyData()
Dim i As Integer
i = 8 ' Start pasting into column H
' Loop until a blank cell is found
Do While Not Selection.Value = 0
With Sheets("Data").Cells(i + 112, 3)
' Select each cell in "Data", starting on C120
.Select
' Copy the value into "Model", starting on H2
Sheets("Model").Cells(2, i).Value = .Value
End With
Loop
End Sub
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
I am working with a column of data in which the range (e.g. how many rows of data there'll be) will eventually vary for each new sheet that a user creates.
On one sheet, the range in B may be from B3:B7, on another, it may be from B3:B22 for example.
I want a Macro that copies the data from the range B3:Bn, with n being the last row before there is a blank cell in the next row. For example, Copy B4:B7, and in B8 there is a blank cell. I want to paste this range into another workbook, in column C.
I'm only a beginner in VBA and have not gotten far with the code. I have tried several iterations of a loop but it doesn't really work.
This is the weak code i have so far. Any help is appreciated.
Sub main()
Dim r As Range
Set r = Range("B3")
Do While r.Value <> ""
Range("C").Value = r.Value
Set r = r.Offset(1)
Loop
End Sub
See this is a Simple code to get you started. Change the Names accordingly
Sub main()
Dim wba As Workbook
Dim wbb As Workbook
Set wba = Workbooks("Workbook A")
Set wbb = Workbooks("Workbook B")
with wba.Worksheets("Worksheet in A")
.Range("B3", .Range("B3").End(xlDown)).Copy
End With
wbb.Worksheets("Worksheet in B").Range("C3").PasteSpecial xlPasteValues
End Sub
A is the workbook with Data, B where you have to copy.
Change the sheet names on both Workbooks, and Range("B3", Range("B1").End(xlDown)) will select the range till a blank cell.
I just want to add one thing to Mikku's code. Instead of xlDown, in this case xlUp might be better. Because there might be one cell blank and next cell is not. When looking for last row, xlUp is good practice.
wba.Worksheets("Worksheet in A").Range("B3", Range("B" & Rows.Count).End(xlUp)).Copy
The problem that I'm facing is concerning Excel. I'm trying to extract rows with multiple columns out of sheets based on certain criteria. I've found some solutions regarding this, but nothing is really what I'm looking for or I can't change it to make it work. I'll try to explain the issue more detailed below using an example.
Situation:
8 sheets (named Sh1 to Sh8) with a list of tasks
Each sheet represents a kind of task (personal, work, ...)
Each sheet has the same format
Data is located starting from row 4 and between column A to K
Below the data is a row with total calculations
The data includes text, numbers and blank cells
Column D is the status of the task (C for completed, I for in progress, N for not started)
Style of the sheets is completely done by using conditional formatting
I would like something that checks those 8 sheets and copies all entries (including the blank cells) that are a certain status, being either C, I or N, to a new sheet, called "Filtering". The filtering sheet will have headers as well and the data should start at row 7.
When I started this, I came up with a formula (based on this) that copies all the entries of one sheet. I could filter it by putting C, I or N in the cell D4 on the filtering sheet.
{
=IFERROR(
INDEX(
Sh1!A$4:A$19;SMALL(
IF(
Sh1!$D$4:$D19=Filtering!$D$4;
ROW(Sh1!A$4:A$19)-ROW(Sh1!A$4)+1
);
ROWS(Sh1!A$4:Sh1!A4)
)
);
"")
}
As I said before, the data includes blank cells, so I changed the formula to the following to make sure the blank cells didn't turn into 0's:
{
=IFERROR(
IF(
INDEX(SAME AS ABOVE)="";
"";
INDEX(SAME AS ABOVE);
);
"")
}
Although this worked, I could only perform this on one sheet, and not on all eight. I could solve this by starting Sh2 at a lower row in the filtering sheet and do this for all other sheets, but that's not really what I'd like to get. I would really like to get to a continuous list that sums up all the not started, completed or in progress by changing that one cell D4 on the filtering sheet.
That's where I would like your suggestions. If it's possible to do this without VBA, I'd prefer that, since I sometimes use it in the online web application and macro's don't work there. If VBA is the only solution, obviously that'd be okay too.
On a side note: I tried VBA based on a code that I found here. (please have patience with me, I never coded before this) but it seems really slow to process this. Every time I run the macro, it takes more than 15 seconds to calculate this, although there are only 200 tasks that I currently have. The following was for getting all the completed tasks. I could easily make the others by changing the C to I or N. There was another problem where the whole sheet was removed, including my headers, so I'd have to put a range on the clear.
Sub ExtractList()
Dim ws As Worksheet
Dim destinationWorksheet As Worksheet
Dim columnD As Range
Dim c As Range
Dim count As Long
Set destinationWorksheet = ActiveWorkbook.Worksheets("Filtering")
destinationWorksheet.Cells.ClearContents
count = 1
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Sh1" Or ws.Name = "Sh2" Or ws.Name = "Sh3" Or ws.Name
= "Sh4" Or ws.Name = "Sh5" Or ws.Name = "Sh6" Or ws.Name = "Sh7" Or
ws.Name = "Sh8" Then
Set columnD = ws.Range("D:D") 'columnD
For Each c In columnD
If WorksheetFunction.IsText(c.Value) Then
If InStr(c.Value, "C") > 0 Then
c.EntireRow.Copy
destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats
count = count + 1
End If
End If
Next c
End If
Next ws
End Sub
Thanks already for reading through this and I'm looking forward to your suggestions.
Cheers,
Bart
The reason your code is taking too long to run is because you are looping through the entire column. You need to delimit the range to work with.
This solution:
• Allows the user to determine the extraction criteria using cell D4 in “Filtering” worksheet (Target)
• Sets the data ranges for each worksheet [Sh1, Sh2, Sh3, Sh4, Sh5, Sh6, Sh7, Sh8] (Source)
• Uses AutoFilter to select the data required and
• Posts the resulting ranges from all worksheets in the “Filtering” worksheet
It assumes that:
• All worksheets involved have the same structure and headers
• Headers are located at A6:K6 for Target worksheet and A3:K3 for Source worksheets (change as required)
Sub ExtractList()
Dim wshTrg As Worksheet, wshSrc As Worksheet
Dim sCriteria As String
Dim rDta As Range
Dim rTmp As Range, rArea As Range, lRow As Long
Rem Set Worksheet Target
Set wshTrg = ThisWorkbook.Worksheets("Filtering") 'change as required
Rem Clear prior data 'Header at row 6 & data starts at row 7 - change as required
With wshTrg
Rem Sets Criteria from Cell [D4] in target worksheet
sCriteria = .Cells(4, 4).Value2
.Cells(7, 1).Value = "X" 'To set range incase there is only headers
.Range(.Cells(7, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents
End With
Rem Process each worksheet
lRow = 7
For Each wshSrc In ThisWorkbook.Worksheets
Select Case wshSrc.Name
Case "Sh1", "Sh2", "Sh3", "Sh4", "Sh5", "Sh6", "Sh7", "Sh8"
With wshSrc
Rem Clear AutoFilter
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Rem Set Data Range
Set rDta = .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 11))
End With
With rDta
Rem Apply AutoFilter
.AutoFilter Field:=4, Criteria1:=sCriteria
Rem Set resulting range
Set rTmp = .Offset(1).Resize(-1 + .Rows.count).SpecialCells(xlCellTypeVisible)
Rem Clear Autofilter
.AutoFilter
End With
Rem Post Resulting range in target worksheet
For Each rArea In rTmp.Areas
With rArea
wshTrg.Cells(lRow, 1).Resize(.Rows.count, .Columns.count).Value = .Value2
lRow = lRow + .Rows.count
End With: Next: End Select: Next
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Range Object (Excel), Range.Offset Property (Excel),
Range.SpecialCells Method (Excel),
Select Case Statement, Worksheet.AutoFilter Property (Excel),
Worksheet.AutoFilterMode Property (Excel), With Statement
Re: Creating a master sheet from multiple sheets.
Multiple sheet description: table with many rows and columns. Columns headings are identical but rows vary. Each sheet is a date.
Task: to take a single value from a specific column (always happens to be column M). the value I want is the total of that column. Take this summed value and insert into a master sheet.
My attempt so far is:
Sub append_master_sheet()
Dim wAppend As Worksheet, wSheet As Worksheet
Dim LastRow As Long
Set wAppend = Worksheets("Master")
For Each wSheet In Worksheets
If wSheet.Name <> wAppend.Name Then
LastRow = WorksheetFunction.Max(3, wAppend.Cells(65536, 2).End(xlUp).Row)
wSheet.UsedRange.Resize(, 13).Copy Destination:=wAppend.Cells(LastRow, 2)
End If
Next wSheet
End Sub
1). it takes all 13 columns rather than only the 13th column. (I see that is because I have set it at 13 as I do not know how to cycle through the preceding columns and skip them to only return the 13th column data (and within this column return the total of the column, not the discrete line items
2) Besides returning all the data which is a problem, it actually consistently skips the final value in the column M.
Can you advise how to amend above code to
1) only return the summed value from column M in the multiple sheets (calendar dates) and insert into master.
thanks,
N
Is this what you are trying (UNTESTED)
Like I mentioned in the comment above, see THIS link on how to find a last row in a column.
I have commented the code so that you will not have a problem understanding it. But if you do, simply post back :)
Note: I am assuming that the last cell in Col M has the SUM
Option Explicit
Sub append_master_sheet()
Dim wAppend As Worksheet, wSheet As Worksheet
Dim wApLRow As Long, wShLRow As Long
Set wAppend = ThisWorkbook.Worksheets("Master")
'~~> Get the last row where the ouput should be placed
wApLRow = wAppend.Range("B" & wAppend.Rows.Count).End(xlUp).Row + 1
For Each wSheet In Worksheets
If wSheet.Name <> wAppend.Name Then
With wSheet
'~~> Fuind the last row in Col M which has the sum
wShLRow = .Range("M" & .Rows.Count).End(xlUp).Row
'~~> Copy over the values to Master Sheet
wAppend.Range("B" & wApLRow).Value = .Range("M" & wShLRow).Value
'~~> Increment the row for next output
wApLRow = wApLRow + 1
End With
End If
Next wSheet
End Sub