I am trying to create macro to copy data from multiple sheets to single sheet, data which is updated frequently on each sheets and looking to avoid repetition in data copy if every time I run macro.
I have written below code but its throwing runtime error, please help to solve this error, so I can complete my project.
Private Sub CommandButton1_Click()
Dim Lastrow As Long, erow As Long, totalSheets As Long
totalSheets = Worksheets.Count
For i = 1 To totalSheets
If Worksheets(i).Name <> "Summary" Then
Lastrow = Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Row
For j = 5 To Lastrow
Worksheets(i).Activate
Worksheets(i).Cells(i, 1).Copy
erow = Summary.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets(i).Paste Destination = Worksheets("Summary").Cells(erow, 2)
Worksheets(i).Cells(i, 2).Copy
Worksheets(i).Paste Destination = Worksheets("Summary").Cells(erow, 3)
Worksheets(i).Cells(i, 11).Copy
Worksheets(i).Paste Destination = Worksheets("Summary").Cells(erow, 4)
Next
End If
Next
i think this is an easy way accomplish your goal:
Option Explicit
Private Sub CommandButton1_Click()
Dim Lastrow As Long, erow As Long, i As Long, j As Long
Dim wsSummary As Worksheet
Set wsSummary = ThisWorkbook.Worksheets("Summary")
For i = 1 To ThisWorkbook.Worksheets.Count
With Worksheets(i)
If .Name <> "Summary" Then
Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
For j = 5 To Lastrow
erow = wsSummary.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'make usre that column A has data.
.Cells(j, 1).Copy wsSummary.Cells(erow, 2) 'Have in mind that the specific copy - paste method also copy formats.
.Cells(j, 2).Copy wsSummary.Cells(erow, 3)
.Cells(j, 11).Copy wsSummary.Cells(erow, 4)
Next
End If
End With
Next
End Sub
Related
Macro copies certain columns from one sheet to other. I can't get it to paste from row 4 on sheet 2 instead of row 2.
Sub CopyPaste()
Dim lastrow As Integer, erow As Long, sheet1 As Worksheet, sheet2 As Worksheet
Set sheet1 = Worksheets("Sheet1")
Set sheet2 = Worksheets("Sheet2")
lastrow = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
erow = sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
sheet2.Cells(erow, 2) = sheet1.Cells(i, 3)
sheet2.Cells(erow, 3) = sheet1.Cells(i, 4)
sheet2.Cells(erow, 4) = sheet1.Cells(i, 9)
Next i
End Sub
skip the loop and assign the whole range as one:
Sub CopyPaste()
Dim sheet1 As Worksheet
Set sheet1 = Worksheets("Sheet1")
Dim sheet2 As Worksheet
Set sheet2 = Worksheets("Sheet2")
Dim lastrow As Long
lastrow = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Dim erow As Long
erow = sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
sheet2.Cells(erow, 2).Resize(lastrow - 1).Value = sheet1.Cells(2, 3).Resize(lastrow - 1).Value
sheet2.Cells(erow, 3).Resize(lastrow - 1).Value = sheet1.Cells(2, 4).Resize(lastrow - 1).Value
sheet2.Cells(erow, 4).Resize(lastrow - 1).Value = sheet1.Cells(2, 9).Resize(lastrow - 1).Value
End Sub
This code is running perfectly fine on inserting blank rows based on a cell value, but now I need to also fill out those new rows in range("E") saying "False". Not sure how to make this work.
Sub Procedure1()
Dim i As Integer
Dim LastRow As Long
LastRow = Sheets("Sheet1").Cells(Rows.Count, "F").End(xlUp).Row
For i = LastRow To 2 Step -1
a = Sheets("Sheet1").Cells(i, 8).Value
For j = 1 To a
Sheets("Sheet1").Rows(i + 1).Select
Selection.Insert Shift:=xlDown
Next
Next
Sheets("Sheet1").Cells(i, 1).Select
End Sub
Any thoughts?
You can avoid the inner loop using Resize.
And you can generally avoid Select.
Sub Procedure1()
Dim i As Long, j As Long
Dim LastRow As Long
Dim a
With Sheets("Sheet1")
LastRow = .Cells(Rows.Count, "F").End(xlUp).Row
For i = LastRow To 2 Step -1
a = .Cells(i, 8).Value 'best to check this is a number before going further
.Rows(i + 1).Resize(a).Insert Shift:=xlDown
.Range("E" & i + 1).Resize(a).Value = "False"
Next
End With
End Sub
With the code I am currently using it will paste the information from Worksheet 1 to worksheet 2 in the Top line of worksheet2. What I want next is to use the same code but for different cell values and to copy the information from worksheet 1 to worksheet 2 but in the next available line in worksheet 2.
I have been researching about excel macros and vba for a while now and I am still having trouble. I have worked on not using select and activate within my excel code but I am still having trouble with my code now. I am trying to automate my excel workbook as much as I can for easier use.
Sub Copy()
Dim Cell As Range
Dim myRow As Long
myRow = 1
With Sheets("Sheet1")
For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
If Cell.Value = "Tuck Chow" And Cell.Offset(0, 1).Value = "OPT" Then
.Rows(Cell.Row).Copy Destination:=Sheets("Sheet2").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
I would do something like this:
Sub Copy()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim newRow As Long
'setting sheets
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
With sh1
For Each cel In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
If cel.Value = "Tuck Chow" And cel.Offset(0, 1).Value = "OPT" Then
'getting new row on Sheet2
If sh2.Cells(1, 1) = "" Then
newRow = 1
Else
newRow = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
'copying
cel.EntireRow.Copy Destination:=sh2.Cells(newRow, 1)
End If
Next cel
End With
'deselecting row
sh2.Cells(1, 1).Select
End Sub
Try:
Option Explicit
Sub test()
Dim LastRow1 As Long, LastRow2 As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow1
If .Range("A" & i).Value = "Tuck Chow" And .Range("B" & i).Value = "OPT" Then
LastRow2 = ThisWorkbook.Worksheets("Sheet2").Cells(ThisWorkbook.Worksheets("Sheet2").Rows.Count, "A").End(xlUp).Row
.Rows(i).Copy ThisWorkbook.Worksheets("Sheet2").Rows(LastRow2 + 1)
End If
Next i
End With
End Sub
I am trying to create a macro to copy and paste data from one Sheet to another sheet when Header and Column A data is matching and want to paste into the specific cell.
below code is working fine for me when Row(headers) order is the same in both sheets. but I need a solution for when the row (Headers) are not in the order.
"I hope I was able to explain my problem"
Sub transfer()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
lastrow1 = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
myname = Sheets("sheet1").Cells(i, "A").Value
Sheets("sheet2").Activate
lastrow2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("sheet2").Cells(j, "A").Value = myname Then
Sheets("sheet1").Activate
Sheets("sheet1").Range(Cells(i, "B"), Cells(i, "F")).Copy
Sheets("sheet2").Activate
Sheets("sheet2").Range(Cells(j, "D"), Cells(j, "H")).Select
ActiveSheet.Paste
End If
Next j
Application.CutCopyMode = False
Next i
Sheets("sheet1").Activate
Sheets("sheet1").Range("A1").Select
End Sub
if i understood your goal then may try something like (code is tested with makeshift data)
Sub test()
Dim SrcWs As Worksheet, TrgWs As Worksheet
Dim Col As Long, TrgLastRw As Long, SrclastRw As Long, SrcLastCol As Long, TrgLastCol As Long
Dim SrcRng As Range, TrgRng As Range, C As Range, Hd As String
Set SrcWs = ThisWorkbook.Sheets("Sheet1")
Set TrgWs = ThisWorkbook.Sheets("Sheet2")
SrcLastCol = SrcWs.Cells(1, Columns.Count).End(xlToLeft).Column
TrgLastCol = TrgWs.Cells(1, Columns.Count).End(xlToLeft).Column
For Col = 1 To SrcLastCol
Hd = SrcWs.Cells(1, Col).Value
If Hd <> "" Then
SrclastRw = SrcWs.Cells(Rows.Count, Col).End(xlUp).Row + 1
Set SrcRng = SrcWs.Range(SrcWs.Cells(2, Col), SrcWs.Cells(SrclastRw, Col))
With TrgWs.Range(TrgWs.Cells(1, 1), TrgWs.Cells(1, TrgLastCol))
Set C = .Find(Hd, LookIn:=xlValues) 'each column header is searched in trgWs
If Not C Is Nothing Then
TrgLastRw = TrgWs.Cells(Rows.Count, C.Column).End(xlUp).Row + 1
Set TrgRng = TrgWs.Cells(TrgLastRw, C.Column).Resize(SrcRng.Rows.Count, 1)
SrcRng.Copy Destination:=TrgRng
End If
End With
End If
Next Col
End Sub
The code I have placed below is a combination of what works and what i can't get to work.
The code that is not commented will copy cells to "sheet2" from "sheet1".
What I cannot get to work correctly is the code that I have disabled that would replace my Range Method of coping from "sheet1" to "sheet2".
Also my If Then Code is what will some up what I'm trying to accomplish. I'm trying to get the If statement to search all of column A and copy all Cars that are year 1991 to sheet2.
Mind my poor coding skills I'm Doing my best to show & explain so I can be helped.
Here is the Sheets 1 & 2
(hxxp://s15.postimg.org/orfw7tlaz/test.jpg)
OLD CODE
Sub Macro1()
Set a = Sheets("Sheet1")
Set b = Sheets("Sheet2")
Set c = Sheets("Sheet3")
Dim x
Dim z
Dim lastrow As Long, erow As Long
x = x + 1
z = 2
'lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
'lastrow = b.Cells(Rows.Count, 1).End(xlUp).Row
'For i = 2 To lastrow
lastrow = b.Range("A" & Rows.Count).End(xlUp).Row + x
'If a.Cells(i, 1) = “1991” Then
'a.Cells(i, 1).Copy
'erow = b.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'b.Paste Destination:=b.Range.Cells(erow, 4)
Range("A" & z).Copy Destination:=b.Range("D" & lastrow)
'a.Cells(i, 1).Copy
'b.Paste Destination:=b.Range.Cells(erow, 1)
Range("B" & z).Copy Destination:=b.Range("A" & lastrow)
'a.Cells(i, 1).Copy
'b.Paste Destination:=b.Range.Cells(erow, 3)
Range("C" & z).Copy Destination:=b.Range("C" & lastrow)
'a.Cells(i, 1).Copy
'b.Paste Destination:=b.Range(erow, 2)
Range("D" & z).Copy Destination:=b.Range("B" & lastrow)
'End If
'Next i
Application.CutCopyMode = False
Sheet2.Columns().AutoFit
'b.Range("A1").Select
End Sub
So I added some Lines and Began changing the cell locations to reflect the format I need and now when I run the macro it only copys the very last line from Sheet1 to sheet2. I believe it has to do with the order of the way these cells are.
b.Cells(erow, 1) = a.Cells(i, 1)
b.Cells(erow, 2) = a.Cells(i, 2)
b.Cells(erow, 3) = a.Cells(i, 3)
b.Cells(erow, 4) = a.Cells(i, 4)
Changing these back fixes it so it copys all the cells but its not what I'm trying to do.
The Code I'm Trying to run is Below
NEW CODE Working Thanks to EntryLevel!
Sub TakeTwo()
Dim a As Worksheet
Dim b As Worksheet
Dim c As Worksheet
Set a = ThisWorkbook.Sheets("Sheet1")
Set b = ThisWorkbook.Sheets("Sheet2")
Set c = ThisWorkbook.Sheets("Sheet3")
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = a.Cells(Rows.Count, 1).End(xlUp).Row
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For i = 2 To lastrowsheet1
If a.Cells(i, 1).Value = "AEM" Then
b.Cells(erow, 31) = a.Cells(i, 1) '<------When I modify these
b.Cells(erow, 6) = a.Cells(i, 4) '<------The copied cells
b.Cells(erow, 28) = a.Cells(i, 5) '<------Don't show up
b.Cells(erow, 26) = a.Cells(i, 6) '<------In Sheet2
b.Cells(erow, 46) = a.Cells(i, 11) '<------Only the last
b.Cells(erow, 29) = a.Cells(i, 14) '<------Line found Is copied to sheet2
erow = erow + 1
End If
Next i
Application.CutCopyMode = False
b.Columns.AutoFit
'b.Range("A1").Select
End Sub
Now Using Same Working Code But Different function Not Working
Sub TakeThree()
Dim a As Worksheet
Dim b As Worksheet
Dim c As Worksheet
Set a = ThisWorkbook.Sheets("Sheet1")
Set b = ThisWorkbook.Sheets("Sheet2")
Set c = ThisWorkbook.Sheets("Sheet3")
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = c.Cells(Rows.Count, 1).End(xlUp).Row
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For i = 2 To lastrowsheet1
If c.Cells(i, 1).Value = b.Cells(erow, 6).Value Then 'If serial number is found from sheet2 column 6 in sheet3 Column 1
b.Cells(erow, 8) = c.Cells(i, 2) 'Then copy description from sheet3 cell row to Sheet2 cell row
erow = erow + 1
End If
Next i
Application.CutCopyMode = False
b.Columns.AutoFit
c.Columns.AutoFit
'b.Range("A1").Select
End Sub
So I added another For Loop with Dim r and added another Line erow = erow + r & now the code copys the first 2 rows needed but does not continue iterating down the list. which is confusing me. here is the code below i have added.
Dim r As Long
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = c.Cells(Rows.Count, 1).End(xlUp).Row
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For r = 1 To erow
For i = 2 To lastrowsheet1
If c.Cells(i, 1) = b.Cells(erow, 6) Then
b.Cells(erow, 8) = c.Cells(i, 2)
erow = erow + r
End If
Debug.Print i
Next i
Next r
Based on your statement that I'm trying to get the If statement to search all of column A and copy all Cars that are year 1991 to sheet2, it seems like Autofilter might be an easier solution than looping. You should be able to use something like this:
Sub TestyTestTest()
Dim lastrowsheet1 As Long
Dim lastrowsheet2 As Long
With ThisWorkbook.Sheets("Sheet1")
.AutoFilterMode = False
lastrowsheet1 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(lastrowsheet1, 4)).AutoFilter Field:=1, Criteria1:="1991"
.Range(.Cells(2, 1), .Cells(lastrowsheet1, 4)).SpecialCells(xlCellTypeVisible).Copy
.AutoFilterMode = False
End With
With ThisWorkbook.Sheets("Sheet2")
.AutoFilterMode = False
lastrowsheet2 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastrowsheet2 + 1, 1).PasteSpecial Paste:=xlPasteValues
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
EDIT:
Trying to stick close to your original code, would something like this be more like what you are looking for?
Sub TakeTwo()
Dim a As Worksheet
Dim b As Worksheet
Dim c As Worksheet
Set a = ThisWorkbook.Sheets("Sheet1")
Set b = ThisWorkbook.Sheets("Sheet2")
Set c = ThisWorkbook.Sheets("Sheet3")
Dim i As Long
Dim lastrowsheet1 As Long
Dim erow As Long
lastrowsheet1 = a.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrowsheet1
If a.Cells(i, 1).Value = 1991 Then
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
b.Cells(erow, 1) = a.Cells(i, 1)
b.Cells(erow, 2) = a.Cells(i, 2)
b.Cells(erow, 3) = a.Cells(i, 3)
b.Cells(erow, 4) = a.Cells(i, 4)
End If
Next i
Application.CutCopyMode = False
b.Columns.AutoFit
End Sub
SECOND EDIT - OP's NEW PROBLEM:
It looks like your data is just pasting over itself because erow is defined as the row after the last row in column 1 that is not empty, but you are not actually putting any data into that column, so erow isn't moving down to the next line.
Basically, change the column number in this line:
erow = b.Cells(b.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
The 1 in b.Cells(b.Rows.Count, 1) should be changed to a column number that you paste data into every time. Alternatively, you could use erow as a counter and increment it manually each time through the loop. In that case move the existing line that defines erow up underneath the line that defines lastrowsheet1 and then put erow = erow + 1 inside the loop after all the pasting has taken place but before End if. If you put it after End If, you'll end up with a bunch of blank lines between your data.