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
Related
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
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
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
I'm trying to copy all rows from between two cell values and paste the values in a new column in a new worksheet. Let's say my data is structured in one excel column as such:
x
1
2
3
y
x
4
5
6
y
So I want to copy the 123 and the 456, paste them in a new worksheet in columns A and B respectively, like so:
A B
1 1 4
2 2 5
3 3 6
The code that I have working copies the data just fine, but it only pastes them below each other. Is there any way to amend the following code to paste the copied data in a new column every time the loop runs through?
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "y"
endrow = rownum - 1
rownum = rownum + 2
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
There's a lot going on in that code that doesn't need to. Have a look at the below and see if you can follow what's happening:
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub
you could use:
SpecialCells() method of Range object to catch "numeric" values range
Areas property of Range object to loop through each set of "numeric" range
as follows:
Sub CommandButton1_Click()
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
Dim area As Range
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
to manage data of any format (not only "numeric") between "x"s or "x"s and "y"s, then use
AutoFilter() method of Range object to filter data between "x"s or "x"s and "ys" "
SpecialCells() method of Range object to catch not empty values range
Areas property of Range object to loop through each set of "selected" range
as follows:
Sub CommandButton1_Click()
Dim area As Range
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
.AutoFilterMode = False
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
This type was already mentioned, but since I wrote it, I'll share it as well, using range areas.
This is also assuming layout is actual in the original question and that you are trying to extract a group of numbers.
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet
Dim RangeArea As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)
Next RangeArea
End Sub