I put together a macro that will search through a column in a table I have and ONLY copy-paste the rows of that table which have a numerical value in that column onto the next sheet of the spreadsheet. This happens once a button is pressed. My code is as follows:
Sub Button1_Click()
Dim r As Long, endRow As Long, pasteRowIndex As Long
Set WS = Worksheets("Sheet1")
With WS
Set LastCell = .Cells(.Rows.Count, "C").End(xlUp)
LastCellRowNumber = LastCell.Row
End With
'endRow = 20 of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 2 To LastCellRowNumber 'Loop through sheet1 and search for your criteria
If IsNumeric(Cells(r, Columns("E").Column).Value) And Not IsEmpty(Cells(r, Columns("E").Column).Value) Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).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("Sheet1").Select
End If
Next r
End Sub
This works but my problem with it is that it copies the rows with their formulas (which become unusable once copied), so I needed some sort of paste special to only copy the values. I tried this but either keep getting errors or it doesn't work the same way.. can someone please check it for me and point me in the right direction?
Sub Button1_Click()
Dim r As Long, endRow As Long, pasteRowIndex As Long, Location As Long
Set WS = Worksheets("Sheet1")
With WS
Set LastCell = .Cells(.Rows.Count, "C").End(xlUp)
LastCellRowNumber = LastCell.Row
End With
pasteRowIndex = 1
For r = 2 To LastCellRowNumber 'Loop through sheet1 and search for your criteria
If IsNumeric(Cells(r, Columns("E").Column).Value) And Not IsEmpty(Cells(r, Columns("E").Column).Value) Then 'Found
Location = 1
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Range(Cells(Location, 1)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
Location = Location + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
Thank you so much!
ActiveSheet.Range(Cells(Location, 1)).PasteSpecial xlPasteValues
You cannot nest Cells (singly) within Range - Cells is already a Range:
ActiveSheet.Cells(Location, 1).PasteSpecial xlPasteValues
Related
VBA Creating new sheets from unique column values in Sheet1 + bringing over adjacent row information
Hey all- I'm trying to a script that identifies the unique values in column E (data starts on row 1), creates a new sheet based on those unique values (also names the sheet per the value), and in the new sheet it creates it brings over the information corresponding rows in column A, C, D, and H -
I found this YouTube video that shows the process but instead of the script indentifying the unique values you have to manually input the keyword it is looking for and it only runs it once. I haven't been able to get the 'for loop' to run properly ...
https://www.youtube.com/watch?v=qGZQIl9JJk4&t=561s
Any help would be much appreciated-!
Private Sub CommandButton1_Click()
J = "Test"
Worksheets.Add().Name = J
Worksheets("Sheet1").Rows(1).Copy
Worksheets(J).Activate
ActiveSheet.Paste
Worksheets("Sheet1").Activate
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 5).Value = "XXXX" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets(J).Activate
b = Worksheets(J).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(J).Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub
Something like this:
Private Sub CommandButton1_Click()
Dim sht As Worksheet, c As Range, i As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
For i = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row
CopyDestination(sht.Cells(i, 5).Value).Resize(1, 5).Value = _
Array(sht.Cells(i, 5).Value, sht.Cells(i, 1).Value, _
sht.Cells(i, 3).Value, sht.Cells(i, 4).Value, _
sht.Cells(i, 8).Value)
Next
Application.CutCopyMode = False
End Sub
'Find the next "paste" destination on the appropriate sheet named "v"
' If sheet doesn't exist, create it
Function CopyDestination(v) As Range
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(v)
On Error GoTo 0
If sht Is Nothing Then '<< no existing matching sheet
With ThisWorkbook
Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With
sht.Name = v '<<< assumes "v" is valid as a worksheet name...
End If
'find the first empty cell in Col A
Set CopyDestination = sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Function
I am working on a excel project and I am struggling at the moment with the following.
I am trying to copy data from A2:C2 from sheet1 to sheet2 until I reach an empty row in sheet1.
Also I need to be able to copy each line of data into sheet2 five times.
So copy A2:C2 from sgheet1 to sheet2 and paste it in sheet2 five times. Continue until I reach an empty row in sheet1.
Many thanks for any help or assistance.
Here is the code so far:When I run step by step it copies the first data into sheet 2 five times perfect but then instead of moving onto the next row in sheet 1 it continues to copy the first data into sheet 2
Sub Macro1()
'
' Macro1 Macro
'copy normal data
''Loop until a blank cell is found in Column b
Sheets("Sheet1").Select
Range("B2:D2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("B2:B6").Select
ActiveSheet.Paste
Columns("B:B").EntireColumn.AutoFit
Sheets("Sheet1").Select
Range("B2:D2").Select
Selection.Copy
Sheets("Sheet2").Select
Sheets("Sheet2").Range("b" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
Do While BlankFound = False
x = x + 1
If Cells(x, "b").Value = "" Then
BlankFound = True
End If
Loop
Try this:
Option Explicit
Sub CopyRows()
'always declare all variables
Dim i As Long, lastRow As Long, ws1 As Worksheet, ws2 As Worksheet, k As Long
'set references to worksheets, as we will use them in this sub
Set ws1 = Sheets("sheet1")
Set ws2 = Sheets("sheet2")
k = 1
'determine last non-blank cell in B column in sheet1
lastRow = ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
For i = 2 To lastRow
'loop until last row in B column and copy five times A-C cells to A-C columns in sheet2
ws2.Range("A" & k & ":C" & (k + 4)).Value = ws1.Range("A" & i & ":C" & i).Value
k = k + 5
Next
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 have some rows in copySheet.sheet1 having some special keyword in first column as "Ojha" . So I want to copy those entire row having "Ojha" in first row & paste it into another pasteSheet.sheet2 . At first I found that cell Having "Ojha". So I put it in Foundcell. So now I used...:
Foundcell.EntireRow.Copy
& in another sheet first I find the vacant rows from where the rows will paste, so
RowCount = WorksheetFunction.CountA(pasteSheet.Range("A:A")) + 1
pasteSheet.Range("A" & RowCount).PasteSpecial xlPasteValues
so it pasted only first row having "Ojha"
So now I want to copy all those rows which are having "Ojha" in the first column & paste to pasteSheet next to next.
If you just want to loop through the cells, this will work
Sub Loopy()
Dim sh As Worksheet, ws As Worksheet
Dim Rws As Long, rng As Range, c As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
Application.ScreenUpdating = 0
With sh
Rws = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range(.Cells(1, 1), .Cells(Rws, 1))
End With
With ws
For Each c In rng.Cells
If c = "Ojha" Then
c.EntireRow.Copy
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next c
End With
Application.CutCopyMode = 0
End Sub
You can also use an autofilter macro...
I have 7 tabs in an excel work book. The information in these tabs are all tables. I need to combine these tables so each one starts in the next empty column. The code that I've tried to make starts on the next empty row, instead of the next empty Column.
Basically, I want all of my headers from each table to all be contained in row 1 instead of starting in the next free row.
Sub Combine()
Dim J As Integer
Dim s As Worksheet
Dim NextEmptyCol As Long
NextEmptyCol = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column + 1
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
For Each s In ActiveWorkbook.Sheets
If s.Name <> "Combined" Then
Application.Goto Sheets(s.Name).[A1]
Selection.CurrentRegion.Select
Sheet.UsedRange.Clear
Selection.Copy Destination:=Sheets("Combined"). _
Cells(Columns.Count, 1).End(xlUp)(2)
End If
Next
End Sub
Your code Selection.Copy Destination:=Sheets("Combined").Cells(Columns.Count, 1).End(xlUp)(2) finds the next free row. To find the next free column:
LastCol = Sheets("Combined").Cells(1, Columns.Count).End(xlToLeft).Column
Selection.Copy Destination:=Sheets("Combined"). _
Cells(1, LastCol + 1)