I am working with a file that has 10 columns with varied data in each one. There is only one column that has (fairly) consistent data. I will attach the file so that hopefully it will help with what I am trying to do.
I want to have the unique values copy over to another worksheet. There are multiple ACD options, but I only want ACD to be copied IF the cell above it contains the value RING. Additionally, I would like to copy over the first TIME column, if possible the second. If necessary I will have a macro change the names to the second column to length.
Data File
I know that advanced filters can be utilized but I have not yet been able to figure out how to properly set it up.
Any tips would be greatly appreciated!
Is this what you needed? I'm pretty new to VBA though but it works.
Sub CopyData()
Dim lastrow As Long, LocY As Long, lastcopy As Long
Dim source As Worksheet, dest As Worksheet
Set source = Worksheets("Sheet1")
Set dest = Worksheets("Sheet2")
lastrow = source.Cells(Rows.Count, 1).End(xlUp).Row 'Checks for the last row that contains data in the source
lastcopy = dest.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Checks for the last row with data in the destination and move down by one to prime for data entry
For LocY = 2 To lastrow 'LocY referring to current location
If source.Cells(LocY, 7).Value = "RING" Then 'Check if current locations at column 7 in source sheet contains the value RING
source.Cells(LocY, 2).Copy
dest.Cells(lastcopy, 1).PasteSpecial xlPasteValues 'pastes the value into the last row of destination sheet.
source.Cells(LocY, 7).Copy
dest.Cells(lastcopy, 2).PasteSpecial xlPasteValues
source.Cells(LocY, 10).Copy
dest.Cells(lastcopy, 3).PasteSpecial xlPasteValues
lastcopy = lastcopy + 1 'moves the target row in the destination down by one to prime for data entry.
End If
Next
End Sub
Related
I have two sheets of data. The first sheet is imported data that will show total users to my site from the day before. The second sheet is a table with all historical data from those daily reports. I'd like to automate a way to copy the data from my first sheet (that data will always be in the same cell) to a new row at the bottom of my existing table. Here's what I have:
Sub Insert_New_Rows()
Dim Lr As Integer
Lr = Range("AF" & Rows.Count).End(xlUp).Row
Rows(Lr + 1).Insert Shift:=xlDown
Cells(Lr + 1, "AF") = Cells(Lr, "AF") + 1
Sheets("Day Before").Range("$A$12:$B$12").Copy
Sheets("Historical").Cells(Lr + 1, "AF").Paste
Application.CutCopyMode = False
End Sub
In this, you'll see that my table is in columns AF and AG. When I run this macro, it only adds a row, it does not copy and paste the information.
I am not really sure where your table starts on the sheet "Day Before". So, I am assuming that it starts in row 1. Based on this assumption here is a little revision to your code:
Option Explicit
Sub Insert_New_Rows()
Dim lngNextEmptyRow As Long
Dim lngLastImportRow As Long
Dim shtYstrdy As Worksheet
Set shtYstrdy = ThisWorkbook.Worksheets("Day Before")
With ThisWorkbook.Worksheets("Historical")
lngNextEmptyRow = .Cells(.Rows.Count, "AF").End(xlUp).Row + 1
.Rows(lngNextEmptyRow).Insert Shift:=xlDown
.Cells(lngNextEmptyRow, "AF").Value2 = _
.Cells(lngNextEmptyRow - 1, "AF").Value2 + 1
lngLastImportRow = shtYstrdy.Cells(shtYstrdy.Rows.Count, "A").End(xlUp).Row
shtYstrdy.Range("A1:B" & lngLastImportRow).Copy _
Destination:=.Cells(lngNextEmptyRow, "AF")
End With
End Sub
Changes:
Explicit coding as suggested by #findwindow stating the workbook and the sheet before each Range, Cells, reference.
Copy and paste in one line of code (before three lines of code).
Using lngNextEmptyRow instead of LastRow so be can skip all these +1.
Determine the size (last row) of the table on the sheet "Day Before", so we know how much we need to copy over.
I hope this is the answer you've been looking for. Let me know if I misunderstood something or if anything requires more explanations.
There is no need to Active or Select Ranges. It is best to work with the Ranges directly. Rarely should you use ActiveCell, ActiveWorkSheet, or Selection.
This is how Copy and Paste work
Here is the shorthand for Copy and Paste
Range(SourceRange).Copy Range(DestinationRange)
Know that this will work for you:
Sheets("Day Before").Range("$A$12:$B$12").Copy Sheets("Historical").Cells(Rows.Count, "AF").End(xlUp).Offset(1)
I am working on a for loop that extracts entire rows of data based on the string in the 12th column being equal to "Airfare."
The idea is to copy the rows of data where column 12 (EXPENSE_TYPE) is Airfare and paste it into a second workbook.
My code, below, is not properly looping through all 120 rows of data. When I run my macro, it only extracts the first row of data where my criteria is met. Let me know if you can find my issue. Thanks!
Sub exportDataToOtherWorkbook()
Dim lastRow As Long
Dim i As Long
Dim p As Integer
Dim q As Integer
Dim erow As Long
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If Cells(i, 12) = "Airfare" Then
Range(Cells(i, 1), Cells(i, 16)).Select
Selection.Copy
Workbooks.Open Filename:="C:\users\andrew.godish\Desktop\Practice Files\masterPracticeExtractDataWBtoWB.xlsx"
p = Worksheets.Count
For q = 1 To p
If ActiveWorkbook.Worksheets(q).Name = "Sheet2" Then
Worksheets("Sheet2").Select
End If
Next q
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
Application.CutCopyMode = False
End If
Next i
End Sub
I would suggest an alternative to looping through each row. Loops are very inefficient and should be avoided if possible.
Assuming your data is stored on "Sheet1" (change to meet your requirements) of the workbook you are copying from, you can filter column 12 and copy all of the data in a more simple command like this:
Sub Test()
'Declare source and destination variables
Dim sourceWB As Workbook, destWB As Workbook
Set sourceWB = ThisWorkbook
'Open the workbook to copy the data TO
Workbooks.Open Filename:="C:\users\andrew.godish\Desktop\Practice Files\masterPracticeExtractDataWBtoWB.xlsx"
Set destWB = ActiveWorkbook
sourceWB.Sheets("Sheet1").Range("A1:P1").AutoFilter Field:=12, Criteria1:="Airfare"
'The first offset on the copy is to avoid copying the headers each time, the second offset is to find the last row in the
'list then offset to the next row. Copies data to new workbook
sourceWB.Sheets("Sheet1").AutoFilter.Range.Offset(1).Copy Destination:=destWB.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
destWB.Save
'Clear the filter from the source worksheet
If sourceWB.Sheets("Sheet1").AutoFilterMode Then sourceWB.Sheets("Sheet1").ShowAllData
End Sub
I know this doesn't directly answer your question, but I think this may be an easier, less error-prone method.
So this method follows these steps:
Open the destination workbook
Filter Sheet1 on column 12 for "Airfare" (be sure to change Sheet1 if necessary)
Copy and paste the filtered range to the destination worksheet and workbook
Remove the filter applied to column 12 in the source worksheet
The confusing part may be the use of Offset(1). I use that on the copy to avoid copying the column headers (it offsets the copy area by one row down). I use it on the destination to avoid overwriting the last row (we must find the last used row, then increment down one row).
My aim with this bit of code is to paste the contents of column D into a different Sheet if the contents in column N on the same row within the initial Sheet is = "REDUCE ONLY".
I'm struggling to find a way to paste all the entries into the second Sheet with no blank rows between them.
Currently I'm sorting the initial Sheet so all the REDUCE ONLY entries are in order at the top of the column N so they're ordered correctly in the output sheet but this isn't very robust if I get a different set of values to what's expected in column N. Is there a different way to phrase:
"cfdSht.Cells(c.Row - 1, 1).PasteSpecial Paste:=xlPasteValues"
So far I've got:
Dim c As Range
Dim rCheck As Range
Dim LRMAIN As Long
Dim cfdSht As Worksheet
Dim mainSht As Worksheet
Set mainSht = ThisWorkbook.Worksheets("Sheet1")
Set cfdSht = ThisWorkbook.Worksheets("ProductSettingNgCfd")
''Set Last Row
LRMAIN = mainSht.Range("A2").CurrentRegion.Rows.Count
''Set Range
Set rCheck = mainSht.Range("B2:N" & LRMAIN)
''Copy any value in column D where the value on the same row in column N is "REDUCE ONLY". Paste into second Sheet with starting point adjusted up 1 row.
For Each c In rCheck
If c.Value = "REDUCE ONLY" Then
mainSht.Cells(c.Row, 4).Copy
cfdSht.Cells(c.Row - 1, 1).PasteSpecial Paste:=xlPasteValues
End If
Next
Thanks
Replace this:
mainSht.Cells(c.Row, 4).Copy
cfdSht.Cells(c.Row - 1, 1)
With this
cfdSht.Cells(cfdSht.RowsCount, 1).End(xlUp).Offset(1).value = mainSht.Cells(c.Row, 4).Value
The first part will start at the bottom of the sheet then go up to the first occupied cell then move one down to the first unoccupied cell.
I used the direct assign method, because it is less taxing on the process than copy and paste. As you were looking only for values this will just put the value of the one cell into the other.
At the moment I’m only able to copy&paste stuff from one row.
I use the code below:
Dim lastRow As Long
With Sheets("Tab1")
If Application.WorksheetFunction.CountA(.Columns(3)) <> 0 Then
lastRow = .Cells(Rows.Count, "C").End(xlUp).Row + 1
Else
lastRow = 1
End If
Sheets("Tabelle2").Range("B85:S85").copy
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
My problem is that I need to copy and paste lists. Can someone show me how to use this code to copy&paste lists?
I wanted to copy more rows, like (A25:S25, A27:S27, A30:S30)
It should copy always the same rows.
There are two reasons for your code copying just one row:
The code selects just one row to copy
Sheets("Tabelle2").Range("B85:S85").Copy
The select just on row to Paste
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues …
As it’s not clear if you want to copy several rows despite selecting just one or to copy that one row to several rows I’ll cover both options in order to give you an idea of what to do in both cases:
Setting the range to be copied
a. To copy just range B85:S85 one row only then what you are doing is correct
Wbk.Sheets("Tabelle2").Range("B85:S85")
b. To copy X rows down from row 85 (including row 85)
Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(X)
c. To copy Y rows up from row 85 (including row 85)
Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(1-Y, 0).Resize(Y)
d. To copy the range bounded by any combination of blank rows and blank columns in which "B85:S85" is included (see Range.CurrentRegion Property (Excel))
Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion
Note that this will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards and it will also include any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
This procedure demonstrates the options explained above:
Sub Range_Set()
Dim rSrc As Range
With ThisWorkbook.Sheets("Tabelle2")
'If want to copy just this row 85
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85")
rSrc.Select: Stop
'If want to copy 5 rows down from row 85 (including row 85)
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").Resize(5)
rSrc.Select: Stop
'If want to copy 5 rows up from row 85 (including row 85)
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").Offset(-4, 0).Resize(5)
rSrc.Select: Stop
'If want to copy then range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").CurrentRegion
rSrc.Select: Stop
End With
End Sub
Setting the range where the copy takes place
To copy the source range as it is, then just need to select the first cell of your target range and the paste.special will cover paste the target to all cells required as per the size all target cell. However is you want to copy range B85:S85’ to several cell then you need to select the target rows. For example if we want to copyB85:S85’ over five rows starting at C5 then we need to set the target range as
.Range("C12").Resize(5).PasteSpecial Paste:=xlPasteValues
As we are going to copy only the values of the source, I suggest to use the Range.Value property of the Range object instead of the Copy…Paste method. One advantage of using this property is to avoid the use of the Clipboard.
Try this code (select\adjust the options as per your requirements)
Sub Range_Value()
Dim Wbk As Workbook
Dim lastRow As Long
Dim rSrc As Range
Rem Declare Objects
Set Wbk = ThisWorkbook 'use this if procedure is resident in the wbk with the tables
'Set Wbk = Workbooks(WbkName) 'use this if procedure is not resident in the wbk with the tables - update wbk name
With Wbk.Sheets("Tab1")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Rem Set Copy Range
'since we are going to paste only values then we can save us from using the clippboard
'Sheets("Tabelle2").Range("B85:S85").Copy
'instaed create a range to replace the values of the target range with the values of this range
'Uncomment\Update the option needed according to you requirements
'for this test I'm using option b
'a. To copy just row 85
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85")
'b. To copy X rows down from row 85 (including row 85) X=5
Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(5)
'c. To copy 5 rows up from row 85 (including row 85) Y=5
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(-4, 0).Resize(5)
'd. To copy the range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion
' As mentioned before we won't use the clipboard
'instead we replace the values with the values of the target range created earlier
'however we need to extend the range to the same size of the source range
.Range("C" & lastRow + 1).Resize(rSrc.Rows.Count, rSrc.Columns.Count).Value = rSrc.Value2
End With
End Sub
Hope this is clear enough and helps you to make progress with you coding, nevertheless let me know of any questions you might have.
I'm not quite sure what you're looking for - but here' how to loop:
Sub test()
For i = 25 to 30
Range(Cells(i,1),Cells(i,19)).Copy
Range(Cells(i,20),Cells(i,39)).PasteSpecial xlPasteValues
Next i
End Sub
That copies A25:S25 and pastes to T25:AM25...Then A26:S26, pastes T26:AM26, etc. until row 31.
Well now that the requirements are disclosed, we have the opportunity to apply another method. Bear in mind that the fact that the source range contains multiple areas may give us the idea of series of repetitive "copy paste values" which makes the undesirable use of the clipboard, or a repetitive Range Values.
This time instead of setting the source range as an object (which still can be done) we'll use an Array variable to grab the values of the multi-areas range
to later enter them in the target range as a unified and continuous range in one step.
This procedure sets an array with the values of the source range areas and then sets the values of the array to the target range using the Range.Value property.
Sub Range_MultiAreas_CopyValue()
Const kRowIni As Long = 25
Dim Wbk As Workbook
Dim aRngSrc() As Variant
Dim lRowLst As Long, l As Long, b As Byte
Rem Declare Objects
Set Wbk = ThisWorkbook
Rem Set Array with rows to copy as value
With Wbk.Sheets("Tabelle2")
l = kRowIni
For b = 1 To 30
If .Range("V" & l).Value2 = 0 Then
Rem Resize Array
On Error Resume Next
ReDim Preserve aRngSrc(1 + UBound(aRngSrc))
If Err.Number <> 0 Then ReDim Preserve aRngSrc(1)
On Error GoTo 0
Rem Set Row Values In Array
aRngSrc(UBound(aRngSrc)) = .Cells(l, 2).Resize(, 16).Value2
Rem Increase Row Pointer
l = l + 2
End If: Next: End With
Rem Reset Arrays Structure
With WorksheetFunction
aRngSrc = .Transpose(.Transpose(aRngSrc))
End With
Rem Let Array Values in Target Range
With Wbk.Sheets("Tab1")
lRowLst = .Cells(.Rows.Count, 1).End(xlUp).Row
lRowLst = IIf(.Cells(1, 1) = Empty, 1, lRowLst + 1)
.Cells(lRowLst, 1).Resize(UBound(aRngSrc, 1), UBound(aRngSrc, 2)).Value = aRngSrc
End With
End Sub
Once again let me know of any question you might have about the resources used.
As it is not possible to Copy more than one row at once when gaps are between as siddharth rout said we tried to bypass the problem with looping through every signle row which should be copiedand added an if query.
This code is working and i am using "him" now
j = 0
For i = 1 To 30
With Sheets("Arbeiter-Tage")
If Application.WorksheetFunction.CountA(.Columns(1)) <> 0 Then
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Else
lastRow = 1
End If
Sheets("Vorlage").Activate
If ActiveSheet.Range("V" & 25 + j).Value = 0 Then
ActiveSheet.Range("B" & 25 + j & ":" & "Q" & 25 + j).Copy
.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End With
j = j + 2
I understand that this is a question that has been asked before in a multitude of forms, but every time I try to use the solution to answer my problem, it's not working and I can't figure out how to adjust to make it work for me.
I have a sheet that, with formulas, pulls all of the data from a daily-updated spreadsheet based on NBA games; in other words, who they're playing, what their opponent's rank is, etc... This creates a large spreadsheet with a line for each player with the aforementioned data next to players who are active tonight.
If a player isn't active, his line is blank.
I want to set up a way to automatically parse a new sheet with just the list of active players, skipping the inactive players. I understand that I need to create a looped macro that will go through each cell and copy that cell value if it <>"", but I can't seem to get it to work.
I was able to answer this myself, sorry I wasn't able to post this sooner. I had the macro check for an empty cell in Column P, if there wasn't one, I had it copy that row to a sheet specified by that player's position.
Sub ActivePlayers()
Dim i As Long
Sheets("AllPlayers").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For i = 3 To FinalRow
' Decide if to copy based on column P and which sheet to copy to based on Column B
ThisValue = Cells(i, 16).Value
Position = Cells(i, 2).Value
If ThisValue <> "" Then
Cells(i, 1).Resize(1, 33).Copy
Sheets(Position).Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("AllPlayers").Select
End If
Next i
End Sub