I want to copy ranges from several worksheets to one sheet.
The range to copy is C3 to the last row of data.
I need to paste it into a column on the main sheet in B6, then repeat the process on the next sheet (from C3 again) into the next column C6 and so on to column J.
I tried:
Set WkSh = ActiveSheet
Set DatShs = Sheets(Array("E0303_0", "E0304", "E0305", "E0306", "E0307", "E0308", "E0309", "E0310", "E0311_0"))
Set DatSh = Sheets(DatSh) 'I get Run time Error '13' Type mismatch here
Set Lrow = DatSh.Cells(Rows.Count, "C").End(xlUp)
TnD = DatSh.Range("C:B").Find("*", , , , xlByRows, xlPrevious).Row
Set RngGrp = DatSh.Range("TnD", Lrow)
Sheets("E0303_0").Range(RngGrp).Copy
ActiveWorkbook.WkSh.Range("A6").Paste
ActiveWorkbook.Sheets("E0304").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("C6").Paste
ActiveWorkbook.Sheets("E0305").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("D6").Paste
ActiveWorkbook.Sheets("E0306").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("E6").Paste
ActiveWorkbook.Sheets("E0307").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("F6").Paste
ActiveWorkbook.Sheets("E0308").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("G6").Paste
ActiveWorkbook.Sheets("E0309").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("H6").Paste
ActiveWorkbook.Sheets("E0310").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("I6").Paste
ActiveWorkbook.Sheets("E0311_0").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("J6").Paste
Your code makes no sense after the first 2 lines. You are trying to set a sheet to itself Set DatSh. What you want to do is loop through the array. Your lastrow is not a row number, but a range and you are trying to add to a cell. The following is the logic you want to use, you can modify as needed.
Sub test()
Dim SheetArray As Variant
Set SheetArray = Sheets(Array("E0303_0", "E0304", "E0305", "E0306", "E0307", "E0308", "E0309", "E0310", "E0311_0"))
For i = 1 To SheetArray.Count
LR = Sheets(i).Cells(Rows.Count, 3).End(xlUp).Row
Sheets(i).Range(Sheets(i).Cells(3, 3), Sheets(i).Cells(LR, 3)).Copy
ActiveSheet.Cells(i, 6).Paste
Next i
End Sub
Related
I am having trouble grasping how the operation I'm about to describe can be conceptualized, since I am new to coding.
A big spreadsheet includes 100 columns, and those need to be condensed down to 10 by adding together the columns. There is a key, so that all the columns tagged with "1" go to 1st new column, and so on.
Here is an example:
There are n original columns. Each one of those columns has a key (bottom left), and according to that key it must be added to column 1, 2, 3, or 4 of the new table (bottom right). This is all nice and clean but the real spreadsheet has perhaps 270+ columns and they must be condensed into 10 columns or so for 3000+ ID's where not all ID's have all columns filled.
I am not sure how to create that sort of loop, I thought of looping through the key first, then finding in the original columns each "A", adding them to first column of new table, then doing that through all of them, but I'm not sure how to avoid overwriting old sums with the new ones.
Cheers!
You can do it with SUMPRODUCT. Actually, you can code it on VBA using this same formula of SUMPRODUCT and pasting values or with Evaluate:
=SUMPRODUCT(--($A$2:$A$6=$F14)*$B$2:$M$6*TRANSPOSE(--($B$14:$B$25=G$13)))
Depending on your Excel version maybe you need to input the formula as array formula, so instead of normally, type the formula and press CTRL+ENTER+SHIFT
UPDATE: You can also do it with VBA but you need to make some changes to your source file to make it work with any dataset of any size:
Your data must be alone in a worksheet called DATA
Your keys must be alone in a worksheet called KEYS
The code will generate a new worksheet with the grouped data according to keys. It uses same formula than before, but does it everything alone.
Sub TEST()
Dim wk As Worksheet
Dim rngData As Range
Dim rngKeys As Range
Dim LR As Long 'last non blank row
Dim LC As Long 'last non blank column
Dim ThisKeys As Variant
Set wk = ThisWorkbook.Sheets.Add(, ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) 'add new worksheet for output at end of workbook
With ThisWorkbook.Worksheets("DATA")
LR = .Range("A" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rngData = .Range(.Cells(2, 2), .Cells(LR, LC))
.Range("A2:A" & LR).Copy wk.Range("A2:A" & LR) 'copy names to output
End With
With ThisWorkbook.Worksheets("KEYS")
LR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngKeys = .Range("B2:B" & LR)
.Range("B2:B" & LR).Copy
wk.Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
With wk
.Range("B2:B" & LR).RemoveDuplicates Columns:=1, Header:=xlNo
LR = .Range("B" & .Rows.Count).End(xlUp).Row
ThisKeys = .Range("B2:B" & LR).Value
.Range("B2:B" & LR).Clear
.Range("B1").Resize(1, UBound(ThisKeys)) = Application.WorksheetFunction.Transpose(ThisKeys) 'transpose keys to horizontal
.Range("A1").Value = "Names / Keys"
LR = .Range("A" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("B2").FormulaArray = _
"=SUMPRODUCT(--(DATA!R2C1:R" & rngData.Rows.Count + 1 & "C1=RC1)*DATA!" & rngData.Address(True, True, xlR1C1) & "*TRANSPOSE(--(KEYS!R2C2:R" & rngKeys.Rows.Count + 1 & "C2=R1C)))"
.Range("B2").AutoFill Destination:=Range(.Range(.Cells(2, 2), .Cells(2, LC)).Address), Type:=xlFillDefault 'drag to right
.Range(.Cells(2, 2), .Cells(2, LC)).AutoFill Destination:=Range(.Range(.Cells(2, 2), .Cells(LR, LC)).Address), Type:=xlFillDefault 'drag to right
.Range(.Cells(2, 2), .Cells(LR, LC)).Value = .Range(.Cells(2, 2), .Cells(LR, LC)).Value 'paste as values, not formulas
End With
Erase ThisKeys
Set rngKeys = Nothing
Set rngData = Nothing
Set wk = Nothing
End Sub
I uploaded the file with the code so you can check it out: https://drive.google.com/file/d/1rc8oOPcqP4HBFEyamku24H9hHRFpncq_/view?usp=sharing
I am trying to delete rows till it meets my last row OR fill down rows to align with last row.
Sometimes my sheet will be like below where I need to delete rows to align with my last row number.:
However sometimes my sheet will be like below, where I need to fill down other columns:
Is there a function that can do this? I am finding it hard to determine when to fill up or fill down.
Thanks
keeping in mind the well known caveats of the use of UsedRange, you could give it a try
Dim lastRow As Long
With ActiveSheet ' <- change it to your actual sheet reference
With .UsedRange
lastRow = .Rows(.Rows.Count)
End With
End With
Please test the next code. It assumes that the reference column will be the seventh one and the one to check the 0 formulas value to be the sixth one. Your picture does not contain the columns header...
Sub DeleteRowsOrFillDownDiscontinuous()
Dim sh As Worksheet, lastR As Long, lastR1 As Long, lastCol As Long
Set sh = ActiveSheet
lastR = sh.Range("F" & rows.count).End(xlUp).row
lastR1 = Range("E" & rows.count).End(xlUp).row
lastCol = sh.cells(lastR1, Columns.count).End(xlToLeft).Column
If lastR < lastR1 Then
sh.rows(lastR + 1 & ":" & lastR1).EntireRow.Delete xlUp
ElseIf lastR > lastR1 Then
sh.Range("A" & lastR1, "E" & lastR1).AutoFill _
Destination:=sh.Range("A" & lastR1, sh.Range("E" & lastR))
sh.Range("G" & lastR1, "AG" & lastR1).AutoFill _
Destination:=sh.Range("G" & lastR1, "AG" & lastR)
sh.Range("AI" & lastR1, sh.cells(lastR1, lastCol)).AutoFill _
Destination:=sh.Range("AI" & lastR1, sh.cells(lastR, lastCol))
Else
MsgBox "Nothing te be processed. Everything aligned..."
End If
End Sub
Edited:
Adapted the code for F:F column as reference, AH:AH not changeable, too and existing columns to be processed after AH Column.
Please test it and send some feedback.
I'm trying to sort a range of rows in an Excel sheet which all start with a specific green background colour in the first column, but my vba code does not do it at all and I can't see why. The objective is as an example to get from this:
to this:
Private Sub Sort_Click()
Dim StartRow, EndRow, i As Integer
Dim row As Range, cell As Range
'Discover the data starting and end rows
i = 1
StartRow = 1
EndRow = 1
'Check the first cell of each row for the start of background colour
For Each row In ActiveSheet.UsedRange.Rows
Set cell = Cells(row.row, 1)
If i < 3 Then
If Hex(cell.Interior.Color) = "47AD70" And i = 1 Then
StartRow = row.row
i = 2
ElseIf Hex(cell.Interior.Color) <> "47AD70" And i = 2 Then
EndRow = row.row - 1
i = 3
End If
End If
Next row
'Sort the range
Range("A" & StartRow & ":" & "A" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
End Sub
The code should check the first cell of each row in Column "A" until it reaches the first green backgroend colour where it assigns that row number to the variable StartRow. The loop continues until it no longer detects the green background colour in the first cell. It then assigns that row number - 1 to the variable EndRow. At the end, it sorts the green range numerically using StartRow and EndRow as the range.
Possibly, The Range statement part is not working correctly. I wonder if someone could help with a resolution or a better code all together. The images demonstrate the rows in the green range sorted manually. Thanks in advance
You need to use last parameter of Find method SearchFormat. Set it to whatever format you need:
Sub FGG()
Dim rng As Range, rngStart As Range, rngEnd As Range
'// Clear previous format, if any
Application.FindFormat.Clear
'// Set search format
Application.FindFormat.Interior.Color = Hex("47AD70")
'// Find first cell with format
Set rngStart = Range("A:A").Find(What:="*", SearchFormat:=True)
'// Find last cell with format by using xlPrevious
Set rngEnd = Range("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchFormat:=True)
'// Define final range
Set rng = Range(rngStart, rngEnd)
'// Sort range and say that that the range has no header
rng.Sort Key1:=rng(1), Header:=xlNo
End Sub
Well, I may have been a bit silly on this issue here, however after some more reading it turned out that to sort complete rows rather than column A only, all I simply had to do was to actually specify whole rows rather than a single column, in the sorting part of the code!
And that is dpne by replacing the line:
Range("A" & StartRow & ":" & "A" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
with:
Range("A" & StartRow & ":" & "D" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
All that's happened above is that the "A" in the range section has changed to "D" to cover all used columns for sorting the rows.
I receive a "subscript out of range" at the line starting: Sheets(“Sheet1”).Cells("A", i).EntireRow.Copy . How do I copy and paste the row to the first open row in Sheet2.
Sub IDwalkups()
Dim endRow As Long
Dim Match1() As Variant
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
ICount = 0
endRow = Sheet1.Range("B999999").End(xlUp).Row
Match1 = Sheet1.Range("E3:E" & endRow)
For i = LBound(Match1) To UBound(Match1)
If Match1(i, 1) = "W" Then
Sheets(“Sheet1”).Cells("A", i).EntireRow.Copy Destination:=Sheets (“Sheet2”).Range(“A” & Rows.Count).End(xlUp).Offset(1)
Else
End If
Next i
End Sub
The three errors you have are:
using “ and ” instead of ". For instance, “Sheet1” is a valid variable name and can be used in statements such as “Sheet1” = 5 * 2. Syntactically, it is quite different to "Sheet1" which is a string literal.
Using Cells("A", i) instead of Cells(i, "A") - the first parameter of Cells is the row, and the second parameter is the column.
Not qualifying which sheet you are referring to when using Rows.Count (but there is a good chance that this would have worked anyway)
So
Sheets(“Sheet1”).Cells("A", i).EntireRow.Copy Destination:=Sheets (“Sheet2”).Range(“A” & Rows.Count).End(xlUp).Offset(1)
should have been
Sheets("Sheet1").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Rows.Count).End(xlUp).Offset(1)
I see 2 errors.
First the Copy & Paste are two steps (2 commands). Second, if you use Cells, you have to give row and column as Number-Parameter. You have to change it to Range.
If Match1(i, 1) = "W" Then
Dim sourceRange As Range, destRange As Range
Set sourceRange = ws.Range("A" & i).EntireRow
' or Set sourceRange = ws.Cells(i, 1).EntireRow
sourceRange.Copy
Set destRange = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
destRange.PasteSpecial
End If
This seems like a simple task but I keep running into various errors. I need to filter worksheet B and then copy a column of data. I then need to filter worksheet A and then paste the copied data into a column.
Worksheets("SheetB").Select
lastRowOne = Range("B" & Rows.Count).End(xlUp).Row
Range("DL2:DL" & lastRowOne).AutoFilter Field:=116, Criteria1:="<>Apples"
lastRowTwo = Range("B" & Rows.Count).End(xlUp).Row
Range("DG2:DG" & lastRowTwo).AutoFilter Field:=111, Criteria1:=Target
'Target is already defined earlier in the Macro and functions fine
lastRowThree = Range("B" & Rows.Count).End(xlUp).Row
Range("DX2:DX" & lastRowThree).Copy
Worksheets("SheetA").Activate
lastRowFour = Range("B" & Rows.Count).End(xlUp).Row
Range("A2:A" & lastRowFour).AutoFilter Field:=1, Criteria1:=Target
lastRowFive = Range("B" & Rows.Count).End(xlUp).Row
Range("Z2:Z" & lastRowFive).SpecialCells(xlCellTypeVisible).Select
Selection.PasteSpecial Paste:=xlPasteRange, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
In place of the last line I have also tried:
ActiveSheet.Paste
The first returns a "Run-time error '1004':
PasteSpecial method of range class failed
the ActiveSheet.Paste returns a "Run-time error '1004':
Paste method of Worksheet class failed
Although this code is not the cleanest, it all functions with the exception of the "pasting" onto 'sheetA' in Column Z. I also need the data pasted into AA if that can be included in a fix.
Thanks !
Here's (I hope) the same macro, but without .Select/.Activate, and a little tweaking. For instance, you don't need more than one "lastRow" variable. Since you really just reset it, you can use one.
Sub tester()
' First create, then SET, worksheet variables to hold the sheets. We use these when
' referring to ranges, cells, etc.
Dim aWS As Worksheet, bWS As Worksheet
Set aWS = Worksheets("SheetA")
Set bWS = Worksheets("SheetB")
Dim lastRow As Long 'AFAICT, you only need this one Last Row variable. Just update it each time.
Dim copyRng As Range
With wsB ' working with SheetA
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range("DL2:DL" & lrOne).AutoFilter Field:=116, Criteria1:="<>Apples"
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range("DG2:DG" & lastRow).AutoFilter Field:=111, Criteria1:=Target
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
' We now SET the range we want to copy. We can avoid copy/paste by setting two ranges equal
' to eachother. For now, let's store the COPY RANGE in a Range variable
Set copyRng = .Range("DX2:DX" & lastRow).SpecialCells(xlCellTypeVisible)
End With 'bWS
Dim pasteRng As Range
With aWS
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range("A2:A" & lastRow).AutoFilter Field:=1, Criteria1:=Target
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set pasteRng = .Range("Z2:Z" & lastRow).SpecialCells(xlCellTypeVisible)
End With 'aWS
pasteRng.Value = copyRng.Value
End Sub
The only hesitation I have is the pasting to SpecialCells. AFAIK, if the paste range is different than the copy range, you might get some errors. In any case, try the above and let me know what happens.
An important thing to pay attention to, especially when using multiple worksheets, is that you should be explicit with which sheet you want to get a Range(),Cells(),Rows(),Columns(),etc. Otherwise, it's going to get that info. from the ActiveSheet, whatever that may be.