Hi Can I ask for a sample macro code to compare 2 different columns from 2 different sheets.
Here's the columnA in sheet1
Here's the column A in sheet2
Here's what I need to make as an output in sheet1
Then all cells in column A sheet1 without match such as red in the picture above should be cut and copied in column C in sheet1 like the below
lastly all cells in column A sheet 2 that has no match should be cut as well and pasted in column D in sheet 1 such as ABC:PINK, ABC:VIOLET and ABC:BLACK as shown below
Thanks for the help in advance.
Here's what I got so far
Sub Button1_Click()
On Error GoTo ErrorHndler:
Dim myRange As Range
Dim sRng As Range
Set myRange = Range("A1:A50")
Start:
For Each sRng In myRange
If sRng Like Sheets("Sheet2").Range("A1").Value Then
MsgBox (Sheets("Sheet2").Range("A1").Value) <----it does not pass here
(----I have no Idea what to put here-----)
'GoTo NextCell
Else
'GoTo Start
MsgBox (Sheets("Sheet2").Range("A1").Value)
'MsgBox "Doesn't match" <-----for debugging purposes
End If
NextCell:
Next sRng
ErrorHandler:
MsgBox ""
End Sub
You can search a range for a value using Range.Find
Range.Find returns Nothing if no match is found or a Range if a match is found.
You can check if two objects refer to the same object using the is operator.
Here is an example:
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("Sheet1").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("A1:A" & TotalRows).Copy Destination:=Sheets("Sheet3").Range("A1")
'Go to the destination sheet
Sheets("Sheet3").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("Sheet2").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
End If
Next
End Sub
Related
I have a multicolumn list box and there are many single or duplicate number in first column.
When Click command button then listbox first columns numbers will be match with sheet1
column(B) numbers. Sheet1 column(B) numbers are unique.
Copy sheet1 column(E) data and paste column(C) only matching unique numbers.
Please help me, i am worry about it.
My code is :
Private Sub commandbutton1_Click()
Dim ws As Worksheet
Dim x As Long
Dim fCell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set fCell = .Range("A:A").Find(Me.listbox1.value, , xlValues, xlWhole)
'If record doesn't match, do nothing
If fCell Is Nothing Then Exit Sub
x = fCell.Row
p = .Cells(i, 5).Value
.cells(i, 3).value=p
End With
End Sub
Here is my sample of Listbox1...
Listbox1
My sheet1:
Sheet1
Now when listbox1 First Column (Code) will match with Sheet(Sheet1) Column:B (Code) then
Sheet1 Column:E (H-Qty) copy and paste in Column:C (G-Qty).
Copy and Paste will be only by match (listbox1 & sheet1 => code)
Here is the picture what i want:
Change Sheet1 After Matching
Please, test the next adapted code:
Private Sub commandbutton1_Click()
Dim ws As Worksheet, x As Long, fCell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
If Me.ListBox1.ListIndex = -1 Then Exit Sub 'when nothing selected
ListBox1.BoundColumn = 1 'column where from to return the value
With ws
Set fCell = .Range("A:A").Find(Me.ListBox1.value, , xlValues, xlWhole)
'If record doesn't match:
If fCell Is Nothing Then Exit Sub
x = fCell.row
.cells(x, 3).value = .cells(x, 5).value
End With
End Sub
Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination)
Where Rng1 is the range of data to be copied and Destination is currently a cell reference (E.g B2)
This code will be called multiple times. How can I alter this so that the destination is the same column (E.g column B) but the row is the next empty cell?
E.g so on the first call, B2 onwards is where the values are copied to, then on the next call the next empty cell after the first call is where the second call should start outputting its values. Then the next empty cell for the start of the third call, and so on.
I can alter the Destination variable to just state column letter if something like this:
Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination & ???)
Is along the right lines?
Sub CopyPasteCells()
Dim Rng1 As Range, Rng2 As Range, ws As Worksheet
Set ws = Worksheets("RefindData")
Set Rng1 = ws.Range("C2:C10") 'Copy range as you like
Set Rng2 = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0) 'Paste range starting from B2 and then first empty cell
Rng1.Copy Destination:=Rng2 'Copy/Paste
End Sub
You can also try something like code below.
Assumptions:
Active cell is in the column, where you want to paste the results (you want to paste results in column B -> select cell from B column [for example B2],
The first row is filled with headers, so the results gonna be pasted from second row
Code
Sub CutCopyPaste()
Dim lngCol As Long
Dim rngCopy As Range
Set rngCopy = Range("A1") 'The cell which ic copied
lngCol = Selection.Column 'active column where the results will be pasted
On Error Resume Next
rngCopy.Copy Cells(Cells(1, lngCol).End(xlDown).Row + 1, lngCol)
If Err.Number = 1004 Then
MsgBox "Be sure that active cell is in the column, where the results should be pasted!" & vbNewLine & vbNewLine & "Try again"
Err.Clear
End If
End Sub
You mean like this?
Sub Sample()
Dim rng1 As Range
Dim wsO As Worksheet
Set wsO = Worksheets("RefindData")
Set rng1 = Range("A1:A10")
rng1.Copy Destination:=wsO.Range("B" & _
wsO.Range("B" & wsO.Rows.Count).End(xlUp).Row + 1)
End Sub
Every time you run the macro it will paste in the next available row after the last row.
I have range of cells on Sheet2 F2:F41, which I want to paste into visible cells in Sheet1. Visible cells on Sheet1 are in Range M111:M643. My Problem is, Excel pastes it to another cells as I want.
Snippet for it:
Do I miss loop or something like this?
Sheets("Tabelle2").Select
Dim tgt As Worksheet
Set tgt = ThisWorkbook.Sheets("Tabelle1")
Dim from As Range
Dim destination As Range
Set from = Sheets("Tabelle2").Range("F2:F41") Selection.Copy
Set destination = Sheets("Tabelle1").Range("M11:M643").SpecialCells(xlCellTypeVisible) from.Copy Destination:=Sheets("Tabelle1").Range("M111")
I found this on the internet - I forget where (could have been stackoverflow) - but it should do what you are looking for. You may want to edit out the plethora of messages, I find them helpful to ensure I'm copying pasting the ranges I intended.
Public Sub Copy_Paste_Visible_Cells()
'This subroutine only handles copying visible cells in a SINGLE COLUMN
Dim RangeCopy As Range
Dim RangeDest As Range
Dim rng1 As Range
Dim dstRow As Long
Set RangeCopy = Application.InputBox("Select a range to copy ", "Obtain Range Object", Type:=8)
MsgBox "The range you selected to copy is " & RangeCopy.Address
Set RangeDest = Application.InputBox("Select range to paste onto ", "Obtain Range Object", Type:=8)
MsgBox "The range you have selected to paste onto is " & RangeDest.Address
If RangeCopy.Cells.Count > 1 Then
If RangeDest.Cells.Count > 1 Then
If RangeCopy.SpecialCells(xlCellTypeVisible).Count <> RangeDest.SpecialCells(xlCellTypeVisible).Count Then
MsgBox "Data could not be copied"
Exit Sub
End If
End If
End If
If RangeCopy.Cells.Count = 1 Then
'Copying a single cell to one or more destination cells
For Each rng1 In RangeDest
If rng1.EntireRow.RowHeight > 0 Then
RangeCopy.Copy rng1
End If
Next
Else
'Copying a range of cells to a destination range
dstRow = 1
For Each rng1 In RangeCopy.SpecialCells(xlCellTypeVisible)
Do While RangeDest(dstRow).EntireRow.RowHeight = 0
dstRow = dstRow + 1
Loop
rng1.Copy RangeDest(dstRow)
dstRow = dstRow + 1
Next
End If
Application.CutCopyMode = False
End Sub
Please try this code.
Sub copythis(ByRef rFrom As Range, ByRef rTo As Range)
Dim rVisible As Range
Set rVisible = rFrom.SpecialCells(xlCellTypeVisible)
rVisible.Copy destination:=rTo
End Sub
that should be called like:
Sub caller()
copythis "range with hidden to be copied", "range to receive"
End Sub
VBA Copy column and paste formulas only - not values - to next column
Spreadsheet column B has a random mix of values and formulas. I want to use VBA to copy that column into the next column and only copy the formulas (not the values) into column C. I was able to use the following VBA to some success but it copies every column past B to infinity (where I want it to stop copying after the first column).
Sub Copy_Column_Formulas_NOvalues()
'
' Copy_Column_Formulas_NOvalues Macro
'
Dim oSheet As Worksheet
Dim rng As Range
Dim cel As Range
Set oSheet = Sheets("Sheet1")
With oSheet
Set rng = .Range(.Range("B1"), .Range("B" & .Rows.Count).End(xlUp))
For Each cel In rng
If Left(cel.Formula, 1) = "=" Then
Range(cel.Offset(, 1), cel.Offset(, 1).End(xlToRight)).FormulaR1C1 = cel.FormulaR1C1
End If
Next cel
End With
End Sub
Try this simple macro and let me know if it works,
Sub Copy_Column_Formulas_NOvalues()
Dim i As Long, j As Long
For i = 1 To Sheets("Sheet3").Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, 2).HasFormula Then
Cells(i, 3) = Cells(i, 2).Formula
End If
Next i
End Sub
Change the Sheet3 name as per your needs.
I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub