I am trying to compare two Range and copy data based on IF and AND condition, but AND condition is not working as a result data is being copied only based on IF condition. Please suggest what change should I make in code. Below is Code which I am currently using:
Sub Copy3()
Dim mCell As Range
Dim yRange As Range
Dim mRange As Range
Dim RRange As Range
Set mRange = Worksheets("Sheet2").Range("DB2:DB17")
Set yRange = Worksheets("Sheet2").Range("CZ2:CZ17")
Set RRange = Worksheets("Sheet2").Range("CY2:CY17")
Set target = mRange.Offset(columnoffset:=-3)
Dim P As Long, Q As Long, t As Long
For P = 1 To mRange.Cells.Count
For Q = 1 To RRange.Cells.Count
For t = 1 To yRange.Cells.Count
If mRange.Cells(P).Value <> "" And RRange.Cells(Q).Value <> yRange.Cells(t).Value Then
mRange.Cells(P).Copy target.Cells(P)
End If
Next
Next
Next
End Sub
you can try this (the sheet name and ranges must be changed to reflect the structure of your data). I made the assumption that target points to column A. The address of the cells is traced to make it easier to check if this is in deed what you expect the code to do.
Dim wholeRange As Range
Set wholeRange = Worksheets("Feuil1").Range("A2:D17")
If (Not wholeRange Is Nothing) Then
Dim row As Range, rP As Range, rQ As Range, rR As Range, rT As Range
For Each row In wholeRange.Rows
Set rP = row.Offset(0, 1).Resize(1, 1)
Set rR = row.Offset(0, 2).Resize(1, 1)
Set rQ = row.Offset(0, 3).Resize(1, 1)
Set rT = row.Offset(0, 0).Resize(1, 1)
Debug.Print "P:" + rP.Address + " R:" + rR.Address + " Q:" + rQ.Address + " T:" + rT.Address
If (rP.Cells(1, 1).Value <> "") And (rQ.Cells(1, 1).Value <> rT.Cells(1, 1).Value) Then
rP.Cells(1, 1).Value = rT.Cells(1, 1).Value
End If
Next row
Else
Debug.Print "wholeRange range is not defined"
End If
Related
is there any simple way to swap the data in the form of series as attached 1 to attached 2
you can use simple loops:
Sub swapper()
Dim n As Integer
Dim r As Range 'destination row
Dim s As Range 'source
Dim a As Range 'source row
Set s = Range("A12:C14")
Set r = Range("A17")
For Each a In s.Rows
For n = a.Cells(1, 2).value To a.Cells(1, 3).value
r.value = a.Cells(1, 1).value
r.offset(0, 1).value = n
Set r = r.offset(1, 0)
Next
Next
End Sub
Use pivot tables, can be very helpful for these types of data.
I am having 10 columns from B to L in excel. I want to check for duplicates within this Range. But I want to know which cell is duplicating with another cell(need a reference of parent one). Please help me to arrive the solution. Here is the code which i tried to solve by getting the "comment with cell address". It is incomplete.
Please suggest best way for this problem.
Thanks in advance.
here is my code
Sub bomstruct()
Dim i As Long
Dim j As Long
Dim f As Long
Dim k As Integer
Dim w As Integer
Range("A3").Select
f = Range(Selection, Selection.End(xlDown)).Rows.Count
Dim Cval As Variant
For k = 3 To f
Cells(k, j).Activate
Cval = Cells(k, j).Value
Cadd = Cells(k, j).Address
If Cval = "" Then
Else
For j = 2 To 12
Cells(i, j).Select
g = f + 3
For i = 790 To g
If i = g Then
Cells(i - g + 3, j + 1).Select
Else
Cells(i, j).Select
If ActiveCell.Value = Cval Then
ActiveCell.Interior.ColorIndex = 6
ActiveCell.AddComment (Cadd)
End If
End If
Next i
i = i - g + 3
Next j
End If
Next k
End Sub
Following code checks for all duplicates and marks (comment and color) the duplicates. It ignores empty cells:
Sub callIt()
Dim rng As Range
' Set the range to check
With ActiveSheet
Set rng = .Range(.Range("A3"), .Range("A3").End(xlDown)).Offset(0, 1).Resize(, 11)
End With
' ===== MAYBE NEEDED ==================================
' Remove color
rng.Interior.colorIndex = 0
' Remove comment if there is one
rng.ClearComments
' ======================================================
' Call the function with the range set
colorizeAndCommentDuplicates rng
End Sub
' Colorize duplicates (same .value) in a range and add comment showing the addresses
' of all duplicates found. Ignores empty cells.
' Args:
' rng (Range): Range to check for duplicates
Sub colorizeAndCommentDuplicates(rng As Range)
Dim rngValuesArray As Variant
Dim i As Long, j As Long
Dim currentValue As Variant
Dim dict As Object, dictDuplicates As Object, rngDuplicates As Range
' Create dict to store ranges
Set dict = CreateObject("Scripting.Dictionary")
Set dictDuplicates = CreateObject("Scripting.Dictionary")
' Write range values into array
rngValuesArray = rng.value
' Loop through range array and find duplicates
For i = LBound(rngValuesArray, 1) To UBound(rngValuesArray, 1)
For j = LBound(rngValuesArray, 2) To UBound(rngValuesArray, 2)
currentValue = rngValuesArray(i, j)
' Skip empty cells
If currentValue <> vbNullString Then
' Only check for duplicates of value if we not already have
If Not dict.exists(currentValue) Then
dict(currentValue) = True
Set rngDuplicates = getDuplicatesRanges(currentValue, rngValuesArray, rng(1))
' Check if duplicates found
If Not rngDuplicates Is Nothing Then
' Add ranges of duplicates to dict
Set dictDuplicates(currentValue) = rngDuplicates
End If
End If
End If
Next
Next
' colorize and add comments
markDuplicates dictDuplicates
End Sub
' Check for duplicates in range values array and return range with duplicates
' if duplicates exist or nothing if there are no duplicates.
' Args:
' valuetoCheck (Variant): Look for duplicates of value.
' rngValuesArray (Variant): Array holding values of a range
' to look for duplicates of value in.
' rngTopLeft (Range): First (top left) range of range to look
' for duplicates in.
' Returns:
' (Range) Nothing if no duplicate found else Range (Areas) of
' duplicates found.
Function getDuplicatesRanges(ByVal valueToCheck As Variant, _
ByVal valuesArray As Variant, ByVal rngTopLeft As Range) As Range
Dim rng As Range, rngTemp As Range
Dim arrayDuplicates() As String
Dim i As Long
Dim j As Long
Dim dictDuplicates
ReDim arrayDuplicates(0)
For i = LBound(valuesArray, 1) To UBound(valuesArray, 1)
For j = LBound(valuesArray, 2) To UBound(valuesArray, 2)
' Value found
If valueToCheck = valuesArray(i, j) Then
If arrayDuplicates(0) <> "" Then
ReDim Preserve arrayDuplicates(UBound(arrayDuplicates) + 1)
End If
arrayDuplicates(UBound(arrayDuplicates)) = i & "," & j
End If
Next
Next
' Loop through array with indexes of duplicates if any found
' and convert to range
If UBound(arrayDuplicates) > 0 Then
For i = 0 To UBound(arrayDuplicates)
Set rngTemp = rngTopLeft.Offset( _
Split(arrayDuplicates(i), ",")(0) - 1, _
Split(arrayDuplicates(i), ",")(1) - 1)
If rng Is Nothing Then
Set rng = rngTemp
Else
Set rng = Application.Union(rng, rngTemp)
End If
Next
Set getDuplicatesRanges = rng
End If
End Function
' Colorize and add comment to duplicates
' Args:
' dict (Object): Scripting dictionary holding values that have
' duplicates as key and all ranges of the duplictaes as values.
Sub markDuplicates(ByRef dict As Object)
Dim key As Variant
Dim rngDict As Range
Dim rng As Range
Dim addresses As String
' Loop through duplicates
For Each key In dict.keys
Set rngDict = dict(key)
' Create string with addresses
For Each rng In rngDict
If addresses <> vbNullString Then addresses = addresses & vbCrLf
addresses = addresses & rng.Address
Next
' Colorize and add comment
For Each rng In rngDict
rng.Interior.colorIndex = 6
rng.ClearComments
rng.AddComment addresses
Next
addresses = vbNullString
Next
End Sub
Highlighting the cells that are duplicate with a conditional formatting rule is one method of 'any other ways to identify'.
with worksheets("sheet1")
with .range("B:L")
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=COUNTIF($B:$L, B1)>1"
End With
With .FormatConditions(.FormatConditions.Count)
.Interior.Color = vbRed
End With
end with
end with
Here is a macro that will add a comment to each cell listing the addresses of all the duplicates.
Read the notes in the code.
I use a dictionary to detect the duplicates, and each item in the dictionary is a collection of cell addresses where those duplicates can be found.
As written it is "sorted by rows", but you can easily change the looping to sort by columns if you prefer.
The cell with the comment is excluded from the list of duplicates.
Option Explicit
Sub foo()
Dim d1 As Object, col As Collection
Dim v As Variant, w As Variant
Dim i As Long, j As Long
Dim S As String, sComment As String
Dim R As Range, C As Range
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = TextCompare
'many ways to set bounds of the region to be processed
With Cells(2, 2).CurrentRegion
.ClearComments
v = .Value2 'read values into array for faster processing
End With
'collect the addresses of each value
For i = 1 To UBound(v, 1)
For j = 1 To UBound(v, 2)
If Not d1.exists(v(i, j)) Then
Set col = New Collection
'offset from array index to cell address depends on starting point of array
col.Add Cells(i + 1, j + 1).Address
d1.Add Key:=v(i, j), Item:=col
Else
d1(v(i, j)).Add Cells(i + 1, j + 1).Address
End If
Next j
Next i
'Add the comments
Cells(2, 2).CurrentRegion.ClearComments
For Each v In d1
If d1(v).Count > 1 Then
sComment = ""
S = d1(v)(1)
Set R = Range(S)
For i = 1 To d1(v).Count
S = d1(v)(i)
Set R = Union(R, Range(S))
sComment = sComment & "," & Range(S).Address
Next i
For Each C In R
'Exclude current cell from list of duplicates
S = Mid(Replace(sComment, "," & C.Address, ""), 2)
C.AddComment "Duplicates in" & vbLf & S
Next C
End If
Next v
End Sub
So I have multiple sets of 3 columns. Each set is always in the same column order ("SKU", "Sales". "Date".)
I am wondering is there is a VBA script or other method that would do the following:
1.) Copy G:I
2.) Paste into A:C
3.) Copy J:L
4.) Paste into A:C (Underneath G:I's data)
5.) Copy M:O
6.) Paste into A:C (underneath J:L's data)
7.) Repeat (I would like it to repeat every 3 columns forever, but if that's not possible I'll manually input the columns if I have
to.)
This is a visual of what I'm looking for: http://i.imgur.com/AagLIm8.png
I also uploaded the workbook in case you need it for reference: https://www.dropbox.com/s/wea2nr4xbfo4934/Workbook.xlsx?dl=0
Thanks for the help!
The code below does what you want, and I've included some ".select" lines to help you understand. I suggest you step through it to become clear, as in the animated gif. Then, remove all the ".select" lines of code.
Option Explicit
Sub moveData()
Dim rSource As Range, rDest As Range, r As Range
Dim tbl As Range, rowNum As Integer
Const colNum = 3
Set rDest = Range("A1")
Set rSource = Range("G1")
Set r = rSource
While r <> ""
Set r = Range(r, r.End(xlDown))
Set tbl = Range(r, r.Offset(0, colNum - 1))
tbl.Select
Set tbl = Range(tbl, tbl.End(xlDown).Offset(1, 0))
tbl.Select
tbl.Copy
rDest.Select
rDest.PasteSpecial (xlPasteAll)
Set rDest = rDest.Offset(tbl.Rows.Count, 0)
Set r = r(1, 1)
r.Select
Set r = r.Offset(0, colNum)
r.Select
Wend
End Sub
try to do this:
Sub CopyColumns()
Dim actualRow As Integer
Dim actualColumn As Integer
Dim rowFrom As Integer
Dim myColumns As Integer
Dim startColumn As Integer
myColumns = 3 'the number of columns before start repeating (in your case is SKU, Sales, Date, so there are 3 columns)
startColumn = 7 'the column where start de data. In your example is the Column G
actualRow = 1
actualColumn = 1
rowFrom = 1
Dim eoRows As Boolean
eoRows = False
While eoRows = False
'verify if there's no more data
If Cells(rowFrom, startColumn) = "" Then
eoRows = True
Else
'verify if there's no more row
While Cells(rowFrom, startColumn) <> ""
For i = startColumn To startColumn + myColumns - 1
Cells(actualRow, actualColumn) = Cells(rowFrom, i)
actualColumn = actualColumn + 1
Next
rowFrom = rowFrom + 1
actualRow = actualRow + 1
actualColumn = 1
Wend
rowFrom = 1
startColumn = startColumn + myColumns
End If
Wend
End Sub
So here is the following VBA code I'm currently using. It works perfectly but I need to expand the range to check additional cells but some of those cells could contain empty cells and I don't want to select those.
Is there a way to bypass those empty cells?
Dim RNG1 As Range
Set RNG1 = Range("H1:H30")
Dim randomCell1 As Long
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
With RNG1.Cells(randomCell1)
.Select
'will do something else here, like copy the cell, fill the cell with a color, etc
End With
This should pick only non-empty cells:
Sub marine()
Dim RNG1 As Range, r As Range, c As Collection
Set c = New Collection
Set RNG1 = Range("H1:H30")
For Each r In RNG1
If r.Value <> "" Then
c.Add r
End If
Next r
Dim N As Long
N = Application.WorksheetFunction.RandBetween(1, c.Count)
Set rselect = c.Item(N)
rselect.Select
End Sub
NOTE:
This is an example of a general technique. To make a random pick from a subset of a range, collect the subset and pick from the Collection.
If the values in column H were XlConstants then something like this using SpecialCells
Sub Option_B()
Dim rng1 As Range
Dim rng2 As Range
Dim lngCel As Long
On Error Resume Next
Set rng1 = Range("H1:H30").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
Dim randomCell1 As Long
randomCell1 = Int(Rnd * rng1.Cells.Count) + 1
For Each rng2 In rng1.Cells
'kludgy as there will be multiple areas in a SpecialFCells range with blank cells
lngCel = lngCel + 1
If lngCel = randomCell1 Then
Application.Goto rng2
Exit For
End If
Next
End Sub
A bit too late but no harm in posting :)
Sub test()
Dim rng As Range, cel As Range
Dim NErng
Dim i As Integer
Set rng = Range("A1:A15")
For Each cel In rng
If Len(cel) <> 0 Then
If IsArray(NErng) Then
ReDim Preserve NErng(UBound(NErng) + 1)
NErng(UBound(NErng)) = cel.Address
ElseIf IsEmpty(NErng) Then
NErng = cel.Address
Else
NErng = Array(NErng, cel.Address)
End If
End If
Next
i = Int((UBound(NErng) - LBound(NErng) + 1) * Rnd + LBound(NErng))
Debug.Print Range(NErng(i)).Address
End Sub
EDIT -- #brettdj is right. This is adjusted to better answer the "skip these cells" question.
Try this out:
DangThisCellIsBlank:
RandomCell = Int(Rnd * RNG1.Cells.Count) + 1
With RNG1.Cells(RandomCell)
If .Value <> "" Then
'do stuff
Else
'go back and pick another cell
GoTo DangThisCellIsBlank
End If
End With
Try with IsEmpty(RNG1.Cells(randomCell1))
Dim RNG1 As Range
Set RNG1 = Range("H1:H30")
Dim randomCell1 As Long
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
'Keep Looping until you find a non empty cell
Do While IsEmpty(RNG1.Cells(randomCell1))
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
Loop
'================================================
With RNG1.Cells(randomCell1)
.Select
'will do something else here, like copy the cell, fill the cell with a color, etc
End With
I have two worksheets ( sheet 1 and sheet 2) . Sheet 1 has 500X500 table. I want to
- Loop through each row ( each cell )
- Identify the cells which have a value ' X' in it
- Pick the respective column header value and store it in a cell in worksheet 2
For example
AA BB CC DD EE FF GG HH
GHS X
FSJ X
FSA X
MSD
SKD
SFJ X X
SFJ
SFM X
MSF X
Is there a way of writing a macro which will pull values in the form of
GHS -> GG
FSJ->DD
.
.
SFJ->BB HH
I have tried looping algorithms but does not seem to work. Could anyone please help me as I am very new to macros.
Try this .. Assumed that GHS, FSJ ... in column A
Sub ColnItem()
Dim x, y, z As Integer
Dim sItem, sCol As String
Dim r As Range
z = 1
For y = 1 To 500
sItem = Cells(y, 1)
sCol = ""
For x = 2 To 500
If UCase(Cells(y, x)) = "X" Then
If Len(sCol) > 0 Then sCol = sCol & " "
sCol = sCol & ColumnName(x)
End If
Next
If Len(sCol) > 0 Then
Sheets("Sheet2").Cells(z, 1) = sItem & " -> " & sCol
z = z + 1
End If
Next
End Sub
Function ColumnName(ByVal nCol As Single) As String
Dim sC As String
Dim nC, nRest, nDivRes As Integer
sC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nC = Len(sC)
nRest = nCol Mod nC
nDivRes = (nCol - nRest) / nC
If nDivRes > 0 Then ColumnName = Mid(sC, nDivRes, 1)
ColumnName = ColumnName & Mid(sC, nRest, 1)
End Function
I have placed the values GG, etc., in separate columns of Sheet2, but the code could be modified to put all the information (for a row) in a single cell.
Sub GetColumnHeadings()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range, rng As Range
Dim off As Integer
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng1 = ws1.Range("A1").CurrentRegion
'CurrentRegion is the Range highlighted when we press Ctrl-A from A1
Set rng2 = ws2.Range("A1")
Application.ScreenUpdating = False
For Each rng In rng1
If rng.Column = 1 Then off = 0
If rng.Value = "X" Then
rng2.Value = rng.EntireRow.Cells(1, 1).Value
off = off + 1
rng2.Offset(0, off).Value = rng.EntireColumn.Cells(1, 1).Value
End If
'if we are looking at the last column of the Sheet1 data, and
'we have put something into the current row of Sheet2, move to
'the next row down (in Sheet2)
If rng.Column = rng1.Column And rng2.Value <> "" Then
Set rng2 = rng2.Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
Set rng = Nothing
Set rng2 = Nothing
Set rng1 = Nothing
Set ws2 = Nothing
Set ws1 = Nothing
End Sub
I've also based in on the spreadsheet sample from the original post, where AA appears to be in cell A1.