I have tried to implement similar code from a post that contained this code.
it works great copying from specified cells but I need it to paste the cell values from the source not the cell contents(formula etc.) have tried several things but all give errors
TIA
Sub AlonsoApprovedList()
Dim cell As Range
Dim rngDest As Range
Dim i As Long
Dim arrColsToCopy
arrColsToCopy = Array(1, 3, 4, 5)
'----For every cell in row G on the ESI Project Data sheet----'
Set rngDest = Worksheets("Alonso Approved List").Range("A3")
Application.ScreenUpdating = False
For Each cell In Worksheets("ESI Project Data").Range("G6:G5000").Cells
If cell.Value = "Card" Then
For i = LBound(arrColsToCopy) To UBound(arrColsToCopy)
With cell.EntireRow
.Cells(arrColsToCopy(i)).Copy rngDest.Offset(0, i)
End With
Next i
Set rngDest = rngDest.Offset(1, 0) 'next destination row
End If
Next cell
Application.ScreenUpdating = True
End Sub
rngDest.Offset(0, i).Value = .Cells(arrColsToCopy(i)).Value
Related
I am trying to write some VBA in excel that will clear all cells starting from the next empty cell in Column A (data starts from A2). For example, if A5 is blank then I want A5:P300 to all be cleared (as in all Formula and Data gone). And so on... so if A20 is blank then it deletes everything from A20:P300..
How would I go about writing this? I also need it to refer to the active workbook but a specific worksheet called ("Develop").
Thanks for any help provided.
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("R&DCosts(2)")
Set rng = x.Range("A2:A340").Cells(Rows.Count, 1).End(xlUp)
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Try this code, please:
Sub clearRange_Bis()
Dim sh As Worksheet, firstEmpt As Long
Set sh = ThisWorkbook.Worksheets("R&DCosts(2)")
firstEmpt = sh.Range("A1").End(xlDown).Row + 1
If firstEmpt > 1000000 Then
sh.Range("A2:P300").Clear
Else
sh.Range("A" & firstEmpt & ":P300").Clear
End If
End Sub
A more simple solution
Option Explicit
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("RDCosts(2)") ' you cannot use "&"
Set rng = x.Range("A2:A340", Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
1) My vba copies and pastes columns from sheet a to sheet b (a table) .
2) My next vba code is ran ontop of this table and I get an error.
However if I copy and paste the problem header and data manually from sheet A to Sheet B my macro(2) will work.
Also I should mention this particular column causing the problem is a column with dates. But I have tried both formats, general and date, ive tried using a formula (=SheetA!BU1:) and pasted down into sheet 2, and I've tried a macro to copy and paste the one column.. nothing works!
Not sure if it is my code, table, format, etc.
Here is my copy and paste macro, the type mismatch does not occur here but in my other code that is not included.
Sub importtodatabase(from_ws, to_ws)
Dim rng As Range, trgtCell As Range
Dim src As Worksheet
Dim trgt As Worksheet
Set src = Worksheets(from_ws)
Set trgt = Worksheets(to_ws)
Dim row_num As Integer
Dim Max_row_data As Integer
Dim source_tab As String
Application.ScreenUpdating = False
Sheets(to_ws).Select
Max_row_data = get_max_row("")
If Max_row_data <> 2 Then
Max_row_data = Max_row_data + 1
End If
Sheets("Mappings").Select
max_row = get_max_row("")
With src
For Each rng In Intersect(.Rows(1), .UsedRange).SpecialCells(xlCellTypeConstants)
For row_num = 2 To max_row
If from_ws = Range("BU" & row_num).value Then
If rng = Range("BV" & row_num).value Then
rng = Range("BW" & row_num).value
Exit For
End If
End If
Next row_num
Set trgtCell = trgt.Rows(1).Find(rng.value, LookIn:=xlValues, lookat:=xlWhole)
'If .Range(rng.Offset(1), .Cells(ws.Rows.Count, "A").End(xlUp).row
If Not trgtCell Is Nothing Then
.Range(rng.Offset(1), .Cells(.Rows.count, rng.Column).End(xlUp)).copy
With trgt
.Cells(Max_row_data, trgtCell.Column).PasteSpecial xlPasteValues
End With
End If
'End If
Next rng
End With
Application.ScreenUpdating = False
End Sub
I am trying to write a simple thing that will merge cells in excel with the same information. What I've got thus far is what follows:
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:B1000") 'Set the range limits here
Set rngMerge2 = Range("C2:C1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
For Each cell In rngMerge2
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
So the problem I'm encountering is split into two issues, First I'm trying to get this to work for columns A - AK but as you can see above I don't know how to combine it without just making it repeat the same thing 30 times over. Is there another way to group it.
Also when I assign the range to Range("AF2:AF1000") and Range("AG2:AG1000") then excel in its entirety crashes. I was hoping you all could help steer me into the right direction.
Repeat code inside a subroutine is a sign that some of the routines functionality should be extracted into its own method.
Performance
1000 seems like an arbitrary row: Range("B2:B1000"). This range should be trimmed to fit the data.
It is better to Union all the cells to be merged and merge them in a single operation.
Application.DisplayAlerts does not need to be set to True. It will reset after the subroutine has ended.
Public Sub MergeCells()
Dim Column As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each Column In .Columns("A:K")
Set Column = Intersect(.UsedRange, Column)
If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
Next
End With
Application.ScreenUpdating = True
End Sub
Sub MergeEqualValueCellsInColumn(Target As Range)
Application.DisplayAlerts = False
Dim cell As Range, rMerge As Range
For Each cell In Target
If cell.Value <> "" Then
If rMerge Is Nothing Then
Set rMerge = cell
Else
If rMerge.Cells(1).Value = cell.Value Then
Set rMerge = Union(cell, rMerge)
Else
rMerge.Merge
Set rMerge = cell
End If
End If
End If
Next
If Not rMerge Is Nothing Then rMerge.Merge
End Sub
You keep modifying the cells in rngMerge but not the definition of it before reusing it. This would likely work better if you started at the bottom and worked up as the situation is similar to inserting or deleting rows.
Option Explicit
Private Sub MergeCells()
Dim i As Long, c As Long, col As Variant
Application.DisplayAlerts = False
'Application.ScreenUpdating = false
col = Array("B", "C", "AF", "AG")
For c = LBound(col) To UBound(col)
For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
Cells(i, col(c)).Resize(2, 1).Merge
Cells(i, col(c)).HorizontalAlignment = xlCenter
Cells(i, col(c)).VerticalAlignment = xlCenter
End If
Next i
Next c
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I've added a wrapping loop that cycles through multiple columns pulled from an array.
I've also notice the Private nature of the sub procedure and I'm guess that this is in a worksheet's private code sheet (right-click name tab, View Code). If the code is to be run on multiple worksheets, it belongs in a public module code sheet (in the VBE use Insert, Module) and proper parent worksheet references should be added to the Cells.
It appears you are running the same procedure on rngMerge and rngMerge2, and that they are the same size.
I suggest the following, where you just iterate through the columns, and then through the cells in each column:
Option Explicit
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Dim rngFull As Range
Set rngFull = Range("B2:AK1000")
For Each rngMerge In rngFull.Columns
For Each cell In rngMerge.Cells
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
'Add formatting statements as desired
End If
Next cell
Next rngMerge
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
NOTE As written, this will only handle duplicates. If you have triplets or more, only pairs of two will be combined.
I would frame the problem a bit differently. Your code goes through each cell in the range, compares it to the next cell, and, if the values of the two are equivalent, then merge them together. I think it a bit clearer to check each cell against the previous cell value instead.
Also, you can iterate over the columns in order to avoid code repetition (as mentioned in other answers).
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
Set wks = Sheets("Sheet1")
'To run this code across the entire "used part" of the worksheet, use this:
Set mergeRange = wks.UsedRange
'If you want to specify a range, you can do this:
'Set mergeRange = wks.Range("A2:AK1000")
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
'In that case, the following will return the first cell in the merge area
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
If you want to run this code on multiple ranges, you can isolate the code which carries out the merges within a range, into its own Sub procedure:
Sub MergeCellsInRange(mergeRange As Range)
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
and call it multiple times from your main procedure:
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
Set wks = Sheets("Sheet1")
MergeRange wks.Range("A2:U1000")
MergeRange wks.Range("AA2:AK1000")
End Sub
References:
Excel object model
Global Sheets property, Sheets collection
Worksheet object
UsedRange property
Range object
Cells property
Row property
Offset property
MergeArea property
Value property
VBA
For Each ... In construct
IsEmpty function
Dim statement
Set statement
Sub statement
The code below searches for duplicates in different sheets of my work book. The issue is that it takes a little while for it to be done. How can I add a progress indicator in the status bar at the bottom?
Thank you & Kind regards.
Sub dup()
Dim cell As Range
Dim cella As Range
Dim rng As Range
Dim srng As Range
Dim rng2 As Range
Dim SheetName As Variant
Application.ScreenUpdating = False
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set srng = Sheets("Screener").Range("A7:A2000")
Set rng = Sheets("Rejected").Range("A7:A2000")
Set rng2 = Sheets("Full Data").Range("A7:A2000")
For Each cell In rng
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 4
cella.Offset(, 1) = "Rejected"
End If
Next cella
Next cell
For Each cell In rng2
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 5.5
cella.Offset(, 1) = "Reported"
End If
Next cella
Next cell
Application.ScreenUpdating = True
End Sub
One thing you can do is speed up your code, there's a few things I'd change about it in its current state,
It's really slow to access range objects and their value, you should instead load the ranges into a variant array and cycle through the arrays
If you find a duplicate, you still go through and check every other range in both arrays which wastes time, you should skip to the next range once you've found a duplicate
With that in mind I've rewritten your code like this, it's completely equivalent and runs in less than a second on my machine:
Sub dup()
Dim i As Integer, j As Integer
Dim RejectVals As Variant
Dim ScreenVals As Variant
Dim FullDataVals As Variant
Dim SheetName As Variant
Dim output() As String
'Push column on 'Screener' sheet to the right to make space for new output
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Worksheets("Screener").Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Pull the values from your 3 ranges into arrays to avoid costly cycling through ranges
ScreenVals = Application.Transpose(Sheets("Screener").Range("A7:A2000").Value)
RejectVals = Application.Transpose(Sheets("Rejected").Range("A7:A2000").Value)
FullDataVals = Application.Transpose(Sheets("Full Data").Range("A7:A2000").Value)
'Resize output column to be same size as column we're screening because
'we're going to place it in the column adjacent
ReDim output(LBound(ScreenVals) To UBound(ScreenVals))
'Cycle through each value in the array we're screening
For i = LBound(ScreenVals) To UBound(ScreenVals)
'Skip without checking if the cell is blank
If ScreenVals(i) = vbNullString Then GoTo rejected
'Cycle through each value in the 'FullData' array
For j = LBound(FullDataVals) To UBound(FullDataVals)
'If it's a duplicate then
If ScreenVals(i) = FullDataVals(j) Then
'Set the relevant value in the output array to 'Reported'
output(i) = "Reported"
'Colour the cell on the 'screener' page
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 5.5
'Skip checking more values
GoTo rejected
End If
Next j
'Next cycle through all the 'Rejected' values
For j = LBound(RejectVals) To UBound(RejectVals)
'If it's a duplicate then
If ScreenVals(i) = RejectVals(j) Then
'Set the relevant value in the output array to 'Rejected'
output(i) = "Rejected"
'Colour the cell
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 4
'Skip checking any more values
GoTo rejected
End If
Next j
rejected:
Next i
'Pop the output array in the column next to the screened range
Worksheets("Screener").Range("B7:B2000") = Application.Transpose(output)
End Sub
I check for duplicates in the 'Full Data' sheet first which means if there is a duplicate in both tables then it will default to 'Reported' and a yellow cell, if you'd like the opposite you can swap the order of the loops.
Let me know if there's anything you don't understand
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps