I am trying to copy data from multiple tabs to one single tab. The data need to be filtered first then copied from different tabs to a new tab. Data from different tabs (has random number of lines)should be continuous within the new tab. Due to the size of the data, it is divided into multiple tabs. So merging tabs into one tab first is not an option.
I have below difficulties that need help:
From second tab, I don’t need to copy the header of data. Any command can be added to the code?
Current codes not copying all four tabs, I am not too sure what is the issue
Can my active sheet be a general command instead of specific like ActiveSheet.Range("$A$1:$U$493692")?
See below code
Sub Filter_FSI()
'
' Filter_FSI Macro
'
'
Dim lastRow As String
lastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Train 3-8").Select
ActiveSheet.Range("$A$1:$U$493692").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A1").Select
Sheets("Sheet1").Paste
Sheets("Train 9-14").Select
ActiveSheet.Range("$A$1:$U$539243").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Train 15-25").Select
ActiveSheet.Range("$A$1:$U$528028").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Train 27-41").Select
ActiveSheet.Range("$A$1:$U$298055").AutoFilter Field:=4, Criteria1:="FSI"
ActiveSheet.AutoFilter.Range.Copy
Sheets("Sheet1").Select
Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Copy
Windows("Train Data JULY_Sam Edit.xlsb").Activate
End Sub
So a couple things I noticed with your code - you're declaring lastrow as a string, but that should really be a long since it's representing a number.
Personally, I'm not a fan of autofiltering - and like Peh said above, you want to avoid using Select and Copy/Paste when you can. Try this solution below - it's my personal preference of doing things. We loop through all your worksheets, then loop through every cell in Column D - if it is equal to "FSI", we bring it to Sheet1:
Option Explicit
Sub Filter_FSI()
Dim sht As Worksheet, sht2 As Worksheet
Dim lastrow As Long, i As Long, j As Long, k As Long
Dim myworksheets As Variant
Set sht = ThisWorkbook.Worksheets("Sheet1")
myworksheets = Array("Train 3-8", "Train 9-14", "Train 15-25", "Train 27-41")
'Bring in headers
sht.Range("A1:U1").Value = Worksheets("Train 3-8").Range("A1:U1").Value
k = 2
For i = 0 To UBound(myworksheets)
Set sht2 = Worksheets(myworksheets(i))
lastrow = sht2.Cells(sht2.Rows.Count, 4).End(xlUp).Row
For j = 2 To lastrow
If sht2.Cells(j, 4).Value = "FSI" Then
sht.Range("A" & k & ":U" & k).Value = sht2.Range("A" & j & ":U" & j).Value
k = k + 1
End If
Next j
Next i
End Sub
Related
I have a workbook with 3 sheets: first one is the raw data sheet, then 2 target sheets. I would need a macro that would look at cell C in raw data sheet and based on the 2 values (YES or NO), will copy and paste the range A:Y in sheets 2, respectively 3.
Example: if on C2 in raw data sheet i have YES, copy A2:Y2 and paste into sheet 2, same range A2:Y2. If instead i have the value NO, copy A2:Y2 and paste into sheet 3.
Then go to next row and copy-paste A3:Y3 to sheet 2 if YES or A3:Y3 to sheet 3 if NO.
I wrote something that only works for the 2nd row, but i don't know how to make it loop... so basically when it passes to the next rows, it still copies the values from A2:Y2 to the target sheet, instead of copying A3:Y3, A4:Y4 etc..
Pasting my poor code below:
Sub IdentifyInfraction()
Dim rngA As Range
Dim cell As Range
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A2:Y2").Copy
Worksheets("Value_YES").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A2:Y2").Copy
Worksheets("Value_NO").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
End If
Next cell
End Sub
Please help!!! :-s
Easiest solution would just be to replace the number 2 in each of your ranges to a variable which you then increment at the end your statement, before you go to the next cell.
For example:
Dim i = 2
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_YES").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_NO").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
End If
i = i + 1
Next cell
So, originally we set i = 2, this is to go in line with your starting row of 2 mentioned in your question. Then, Range("A" & i & ":Y" & i).Copy is the same as saying Range("A2:Y2").Copy or Range("A3:Y3").Copy, etc.
This will go through any copy each row, a new row each time, and paste it to the respective row in the various sheets.
I hope this works for what you are trying to do, if not let me know.
There are a few things I'd also recommend looking into. There's a much better way to copy and paste, without going back and forward through the sheets.
ThisWorkbook.Sheets("raw_data").Rows(i).Copy Destination:=Worksheets("Value_YES").Range("A" & i)
Something like this would take the whole row from raw_data and transfer it to Value_YES. You'd have to mess around with it and change the range from Rows(i), but that's just an example.
I'd also recommend that you look into How to avoid using Select in Excel VBA to better understand why it's frowned upon to use Select and Activate in Excel VBA.
My version:
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ys.Range("A" & Yr)
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ns.Range("A" & Nr)
End If
Next c
End With
End Sub
If you really require to paste values, then use this one
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
Application.ScreenUpdating = False
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ys.Range("A" & Yr).PasteSpecial xlPasteValues
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ns.Range("A" & Nr).PasteSpecial xlPasteValues
End If
Next c
End With
Application.CutCopyMode = False
End Sub
you could try this:
Sub IdentifyInfraction()
Dim cell As Range
With Worksheets("raw_data") 'reference "raw data" sheet
For Each cell In .Range("C2", .cells(.Rows.Count, "C").End(xlUp)) ' loop through referenced sheet column C cells from row 2 down to last not empty one
Worksheets("Value_" & cell.Value).Range(cell.Address).Resize(, 25).Value = cell.Resize(, 25).Value 'have proper target sheet A:Y current cell row values as "raw data" sheet ones
Next
End With
End Sub
I am new to this but I am trying to copy multiple cells in an excel workbook and paste them into a separate tab of the same workbook.
Above is a sample of what my spreadsheet looks like, but my spreadsheet has over 800 lines of data.
I need the names to be copied and put into column A of Sheet2 and then the account numbers into column D of Sheet2.
I have tried this 2 different ways.
Using below code:
Sheets("Sheet1").Select
Range("A1,A3,A5,A7,A9").Select
Range("A10").Activate
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A2,A4,A6,A8,A10").Select
Range("A10").Activate
Selection.Copy
Sheets("Sheet2").Select
Range("D1").Select
ActiveSheet.Paste
This gives me a Compile Error Syntax Error.
Code #2
Range("A2").Select
Selection.Cut
Range("D1").Select
ActiveSheet.Paste
Range("A4").Select
Selection.Cut
Range("D3").Select
ActiveSheet.Paste
...
This is keeping them in the same tab, instead of pasting them into a separate tab (I would just copy them over later). I repeat this for each customer. This one gives me a range error that basically says it's too large. Unfortunately, I can't recreate it because I deleted it.
Does anyone have a simpler way of doing this that won't cause an error?
Try this is assuming your data is consistently alternating (Name,acount).
Sub marine()
Dim lr As Long, i As Long
Dim sh1 As Worksheet, sh2 As Worksheet
'/* declare the worksheets and use variables in the rest of the code */
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
With sh1
lr = .Range("A" & .Rows.Count).End(xlUp).Row '/* get the last row in Sheet1 */
For i = 1 To lr '/* loop to all rows identified */
If i Mod 2 = 1 Then '/* check if odd or even, copy in A if odd */
.Range("A" & i).Copy _
sh2.Range("A" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
Else '/* copy in D otherwise */
.Range("A" & i).Copy _
sh2.Range("D" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
End With
End Sub
Above copies data from Sheet1 to Sheet2 but leaves the 1st row blank.
Also, it always copy data on the last row of each column in Sheet2 (A and D). So another approach would be:
Sub ject()
Dim lr As Long, i As Long, lr2 As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rNames As Range, rAcct As Range
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
With sh1
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lr
If i Mod 2 = 1 Then
If rNames Is Nothing Then '/* get all the cells with names */
Set rNames = .Range("A" & i)
Else
Set rNames = Union(rNames, .Range("A" & i))
End If
Else
If rAcct Is Nothing Then '/* get all the cells with accounts */
Set rAcct = .Range("A" & i)
Else
Set rAcct = Union(rAcct, .Range("A" & i))
End If
End If
Next
End With
With sh2
'/* get the last filled Names column in Sheet2 */
lr2 = .Range("A" & .Rows.Count).End(xlUp).Row
rNames.Copy .Range("A" & lr2) '/* execute 1 time copy */
rAcct.Copy .Range("D" & lr2) '/* execute 1 time copy */
End With
End Sub
Above code ensures that the correct account is adjacent to the correct name.
And you might gain execution performance too since one(1) time copy is executed. HTH.
P.S. As much as possible, avoid using Select.
Logic I implemented is to loop until last row in Sheet1 in step of 2. Loop variable indicates always row with name, the following row is account number, so it's easy in a loop to assign these values to particular columns on the other sheet. Also, I used another variable j, which indicates consecutive rows in Sheet2.
Solution:
Sub CopyData()
Dim sourceWs As Worksheet, targetWs As Worksheet, i As Long, lastRow As Long, j As Long
j = 1
Set sourceWs = Worksheets("Sheet1")
Set targetWs = Worksheets("Sheet2")
lastRow = sourceWs.Cells(sourceWs.Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow Step 2
targetWs.Cells(j, 1) = sourceWs.Cells(i, 1)
targetWs.Cells(j, 4) = sourceWs.Cells(i + 1, 1)
j = j + 1
Next
End Sub
I am trying to do something I imagine is really simple however I am stuck on part of the code.
I need the code to look at last row with a number in in column A and fill the series down once i.e.
A20 = 0019
A21 = 0020
Dim LastRow As Variant
Dim LastBlankRow As Variant
LastRow = Range("A" & Rows.Count).End(xlUp).Offset(0).Select
LastRow2 = Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.AutoFill Destination:=Range(LastRow & LastBlankRow), Type:=xlFillDefault
I started off with this code and developed it to the one above however my range will change each time as more data is entered.
Range("A20").Select
Selection.AutoFill Destination:=Range("A20:A21"), Type:=xlFillDefault
Range("A20:A21").Select
I imagine its something simple I have missed however I cant figure it out.
Thanks!
Don't rely on ActiveSheet, always qualify your Range, Rows objects with your Worksheet.
Code
Option Explicit
Sub FillOneDown()
Dim LastRow As Variant
With Worksheets("Sheet1") ' modify "Sheet1" to your sheet's name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRow).AutoFill Destination:=.Range(.Cells(LastRow, "A"), .Cells(LastRow + 1, "A")), Type:=xlFillDefault
End With
End Sub
I'm taking data that is listed across multiple columns and putting it into a single column (A). If there is data in column B, it grabs that data, sticks it at the end of the data in column A, then goes back and deletes the now empty column B, which moves all the other columns over one so now there is data in column B again, up until the point there are no more columns of data except for column A. The way I'm doing this currently is by listing multiple blocks of the same code below which is not efficient obviously and sooner or later the code will break. Any advice is appreciated!!
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Selection.End(xlUp).Select
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Selection.Delete Shift:=xlToLeft
ActiveCell.Offset(0, -1).Range("A1").Select
I like Christmas007's answer. I wanted to share this solution too:
Sub MoveIt()
Dim mysht As Worksheet
Set mysht = ActiveSheet
Set myrng = mysht.UsedRange
nextrow = mysht.Cells(mysht.Rows.Count, 1).End(xlUp).Row
For i = 2 To myrng.Columns.Count
lastColrow = myrng.Cells(mysht.Rows.Count, i).End(xlUp).Row
If lastColrow <> 1 Or myrng.Cells(1, i) <> "" Then
For j = 1 To lastColrow
nextrow = nextrow + 1
mysht.Cells(nextrow, 1) = myrng.Cells(j, i)
Next j
End If
Next i
Range(myrng.Columns(2), myrng.Columns(myrng.Columns.Count)).Clear
End Sub
I like it because it doesn't use the copy, paste, and delete functions. In my experience these functions start to cause the macro to drag if you are dealing with big workbooks and they also require that the sheet is activated.
There is a pretty simple way to do this:
Sub MoveIt()
Dim LastRow As Long
Dim ws1 as Worksheet
Set ws1 = Sheets("Name of Sheet")
Do While (ws1.Range("B1").Value <> "")
LastRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("B1:B" & ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row).Copy
ws1.Range("A" & LastRow).PasteSpecial
ws1.Range("B1").EntireColumn.Delete xlToLeft
Loop
End Sub
I have the following partial code and my for loop breaks ONLY on the 35th tab when I try to activate. The code runs correctly for sheets 6-33. I deleted sheet 34 so I'm thinking it might be because it "jumps" to sheet 35. However, when I debug and place the cursor over endTab I see it contains the value 35. The activate for some reason doesn't work only on this sheet and breaks. Any thoughts?
Dim lastRow As Long
Dim startRow As Long
Dim currentRow As Long
Dim endTab As Integer
Sheets(4).activate
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
startRow = 2
Range("A2:AB" & lastRow).Sort key1:=Range("AB2:AB" & lastRow), _
order1:=xlAscending, Header:=xlNo
For i = startRow To lastRow
Sheets(4).activate
endTab = Range("AB" & startRow + i - 2)
Range("A" & startRow + i - 2 & ":" & "AB" & startRow + i - 2).Copy
Worksheets(endTab).activate
Columns("A").Find("", Cells(Rows.Count, "A")).PasteSpecial xlPasteValues
Next
From comments:
Sheet code names are created when the sheet is first created - they do not adjust to match the order of the sheets in the workbook. Your code is addressing "the 35th sheet" (counting your sheet tabs from left to right) which is not the necessarily the sheet with the codename of "Sheet35"