Copy/Paste Range from one sheet to another - excel

I am trying too simply copy the cells with data in col A of a worksheet to another worksheet at row 2. With the following script the source worksheet name is entered into row 1 of Ave RLD worksheet. If that is all I try to do it will loop through all the worksheets and place their names in the next col of Ave RLD. As soon as I try to copy the data from col A and paste it to Ave RLD I get a Run time error 1004. I left in all the commented lines of things I have been trying. What am I missing?
Dim WS_count As Long
Dim I As Long
Dim ws As Worksheet
Dim ColNum As Long
Dim wksName As String
Dim NumRows As Long
ColNum = 1
Sheets.Add Type:=xlWorksheet
ActiveSheet.Name = "Ave RLD"
For Each ws In ActiveWorkbook.Worksheets
If Left(Trim(ws.Name), 3) = "RLD" Then
wksName = ws.Name
NumRows = ws.Range("A" & Rows.Count).End(xlUp).Row
MsgBox NumRows
With Worksheets("Ave RLD")
.Cells(1, ColNum).Value = wksName
ws.Range(Cells(1, 1), Cells(NumRows, 1)).Copy
.Range(Cells(2, ColNum)).Paste.Values
'.Range(Cells(2, ColNum)).Value = .Range(("A1"), Range("A1").End(xlUp))
'.Range(Cells(2, ColNum)).Value = ws.Range("A" & Rows.Count).End(xlUp).Row
'MsgBox ws.Cells(1, 26).Value
'.Cells(2, ColNum).Value = .Worksheets(wksName).Cells(1, 26)
'.Worksheets(wksName).Cells(1, 1).Copy
'Worksheets(wksName).Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Copy
'.Cells(2, ColNum).Paste
ColNum = ColNum + 1
End With
End If
Next ws

Does this do what you want?
Lots on this at this site, but this line will error if ws is not the active sheet as you do not fully qualify all the ranges
ws.Range(Cells(1, 1), Cells(NumRows, 1)).Copy
And the other line commented below just needs Range or Cells, also your paste values syntax was off - recording a macro is one way to sort out such details.
Dim WS_count As Long
Dim I As Long
Dim ws As Worksheet
Dim ColNum As Long
Dim wksName As String
Dim NumRows As Long
ColNum = 1
Sheets.Add Type:=xlWorksheet
ActiveSheet.Name = "Ave RLD"
For Each ws In ActiveWorkbook.Worksheets
If Left(Trim(ws.Name), 3) = "RLD" Then
wksName = ws.Name
NumRows = ws.Range("A" & Rows.Count).End(xlUp).Row
MsgBox NumRows
With Worksheets("Ave RLD")
.Cells(1, ColNum).Value = wksName
ws.Range(ws.Cells(1, 1), ws.Cells(NumRows, 1)).Copy 'fully qualify with ws
.Cells(2, ColNum).PasteSpecial xlpasteValues 'just Cells
ColNum = ColNum + 1
End With
End If
Next ws

Related

Macro/VBA: How to copy "striked-out" rows to another worksheet

I have a table with certain rows with "striked-out" font. The objective is to cut these rows and paste them into another sheet.
So far, I have the following code, and is not working (EDIT: a new sheet gets created but nothing is cut nor pasted):
Sub test()
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets.Add After:=ActiveSheet
For i = 2 To lrow
If Cells(i, 1).Font.Strikethrough = True Then
Cells(i, 1).EntireRow.Cut
Sheets(ActiveSheet.Index + 1).Paste
End If
Next i
End Sub
How would I fix this?
More like this:
Sub test()
Dim i As Long, lrow As Long, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Long
Set wsSrc = ActiveSheet 'or something more specific
lrow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
'get a reference to the sheet when adding it
Set wsDest = wsSrc.Parent.Sheets.Add(After:=ActiveSheet)
destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
For i = 2 To lrow
If wsSrc.Cells(i, 1).Font.Strikethrough = True Then
wsSrc.Rows(i).Cut wsDest.Cells(destRow, 1)
destRow = destRow + 1 'next paste row
End If
Next i
End Sub

How to copy values from sheets to another sheet?

I'm trying to merge several sheets into one.
Configuration
DataSheet1 : First sheet
DataSheet2 : Second sheet
ConsolidatedSheet : Consolidated sheet
Code
Set consolidatedSheet = Worksheets("ConsolidatedSheet")
consolidatedSheet.Activate
startRow = 2
startCol = 1
Worksheets("DataSheet1").Activate
lastRow = Cells(Rows.Count, startCol).End(xlUp).row
lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
consolidatedSheet.Range("A" & consolidatedSheet.Cells(Rows.Count, 1).End(xlUp).row + 1)
Worksheets("DataSheet2").Activate
lastRow = Cells(Rows.Count, startCol).End(xlUp).row
lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
consolidatedSheet.Range("A" & consolidatedSheet.Cells(Rows.Count, 1).End(xlUp).row + 1)
Issue
Two arrays are created in the consolidated sheet. It means I can't sort on the consolidated sheet.
How do I copy data as values instead of arrays?
Sub consSheets()
Dim ws As Worksheet
With Worksheets("ConsolidatedSheet")
.Cells.Delete ' clear the assignment sheet first
For Each ws In Sheets(Array("DataSheet1", "DataSheet2"))
ws.Cells(2, 1).CurrentArray.Copy
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Next ws
End With
Application.CutCopyMode = False ' "clears" the clipboard
End Sub
Edit2: (not copy headers from DataSheet1 and DataSheet2 and keep existing header in ConsolidatedSheet)
Sub consSheets()
Dim ws As Worksheet
With Worksheets("ConsolidatedSheet")
.Rows("2:" & .UsedRange.Row + .UsedRange.Rows.Count).Delete ' clear (without header in Row 1) the assignment sheet first
For Each ws In Sheets(Array("DataSheet1", "DataSheet2"))
Set Rng = ws.Cells(2, 1).CurrentRegion
Set Rng = Intersect(Rng, Rng.Offset(1)) ' eliminate headers
If Not Rng Is Nothing Then
Rng.Copy
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End If
Next ws
End With
Application.CutCopyMode = False ' "clears" the clipboard
End Sub
I'm not sure what you mean by it creating arrays, and I don't think that code is actually the code using as it's not doing what you describe.
But here's something that does what your intending.
Option Explicit
Sub Test()
Dim cSht As Worksheet
Set cSht = Worksheets("ConsolidatedSheet")
Dim StartRow As Integer, StartCol As Integer
StartRow = 1
StartCol = 1
'Split out to a sub and don't need to repeat self
Call ConsolidateData(cSht, "DataSheet1", StartRow, StartCol, True)
Call ConsolidateData(cSht, "DataSheet2", StartRow, StartCol)
End Sub
Private Sub ConsolidateData(cSht As Worksheet, FromSheet As String, StartRow As Integer, StartCol As Integer, Optional IncludeHeader As Boolean)
Dim FromRow As Integer
If IncludeHeader Then
FromRow = StartRow
Else
FromRow = StartRow + 1
End If
With Worksheets(FromSheet)
lastrow = .Cells(.Rows.Count, StartCol).End(xlUp).Row
lastcol = .Cells(StartRow, .Columns.Count).End(xlToLeft).Column
'Just transfering value is faster then copy, but doesn't bring formatting
cSht.Cells(cSht.Rows.Count, 1).End(xlUp).Resize(lastrow - FromRow, lastcol - StartCol).Value2 = .Range(.Cells(FromRow, StartCol), .Cells(lastrow, lastcol)).Value2
End With
End Sub

Cut and Paste Blocks of Data underneath first block using VBA

I have been trying to come up with/find a VBA code that copies blocks of data under my first block. Each block is 19 columns followed by a blank. The number of rows per block can vary.
See my screenshot below:
Therefore, I would like all my data continuous in the first columns A:S. Any help is highly appreciated.
I found the following code online, but this only pastes everything into the first column
Sub Column()
Dim iLastcol As Long
Dim iLastRow As Long
Dim jLastrow As Long
Dim ColNdx As Long
Dim ws As Worksheet
Dim myRng As Range
Dim ExcludeBlanks As Boolean
Dim mycell As Range
ExcludeBlanks = (MsgBox("Exclude Blanks", vbYesNo) = vbYes)
Set ws = ActiveSheet
iLastcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Alldata").Delete
Application.DisplayAlerts = True
Sheets.Add.Name = "Alldata"
For ColNdx = 1 To iLastcol
iLastRow = ws.Cells(ws.Rows.Count, ColNdx).End(xlUp).Row
Set myRng = ws.Range(ws.Cells(1, ColNdx), _
ws.Cells(iLastRow, ColNdx))
If ExcludeBlanks Then
For Each mycell In myRng
If mycell.Value <> "" Then
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next mycell
Else
myRng.Copy
jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
.End(xlUp).Row
mycell.Copy
Sheets("Alldata").Cells(jLastrow + 1, 1) _
.PasteSpecial xlPasteValues
End If
Next
Sheets("Alldata").Rows("1:1").EntireRow.Delete
ws.Activate
End Sub
Basic approach:
Sub Tester()
Dim c As Range, addr
Set c = ActiveSheet.Range("T1")
Do
Set c = c.End(xlToRight)
If c.Column = Columns.Count Then Exit Do
addr = c.Address 'strire the address since Cut will move c
c.CurrentRegion.Cut c.Parent.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Set c = ActiveSheet.Range(addr) '<< reset c
Loop
End Sub
This is a little more basic than #TimWilliams
With ThisWorkbook.Sheets("Alldata")
Dim lRow As Long, lCol As Long, cpyrng As Range
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 21 To lCol Step 20
If .Cells(1, i).Value <> "" And .Cells(1, i).Offset(, -1).Value = "" Then
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set cpyrng = .Cells(1, i).CurrentRegion
cpyrng.Cut
Sheets("Sheet2").Cells(lRow, 1).Offset(2).Insert Shift:=xlDown
End If
Next i
End With

Copy to the next available line with my code

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

macro to copy and paste data from one Sheet to another when Header is matching

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

Resources