I have two columns one is user name and other one is decision now for each unique user i want 10% data.. for example if user name is Rohit and decision yes than 10% random of all rows where user decision was yes again for no 10% all the row of same user where decision is NO, This code is giving 10% data of unique name from column user only.
Sub Random10_EveryName()
Randomize 'Initialize Random number seed
Application.ScreenUpdating = False
'Copy Sheet1 to new sheet
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
'Clear old data in Sheet 2
Sheets(2).Cells.ClearContents
'Determine Number of Rows in Sheet1 Column A
numRows = Sheets(Sheets.Count).Cells(Rows.Count, _
"A").End(xlUp).Row
'Sort new sheet by Column E
Sheets(Sheets.Count).Cells.Sort _
key1:=Sheets(Sheets.Count).Range("O1:D" & numRows), _
order1:=xlAscending, Header:=xlYes
'Initialize numNames & startRow variable
numNames = 1
startRow = 2
'Loop through sorted names, count number of current Name
For nameRows = startRow To numRows
If Sheets(Sheets.Count).Cells(nameRows, "D") = _
Sheets(Sheets.Count).Cells(nameRows + 1, "D") Then
numNames = numNames + 1
Else:
endRow = startRow + numNames - 1
'Generate Random row number within current Name Group
nxtRnd = Int((endRow - startRow + 1) * _
Rnd + startRow)
'Copy row to Sheet2, Delete copied Name
dstRow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(Sheets.Count).Rows(nxtRnd).EntireRow.Copy _
Destination:=Sheets(2).Cells(dstRow, 1)
Sheets(Sheets.Count).Cells(nxtRnd, "D").ClearContents
'Set Start Row for next Name Group, reset numNames variable
startRow = endRow + 1
numNames = 1
End If
Next
'Sort new sheet by Column O
Sheets(Sheets.Count).Cells.Sort _
key1:=Sheets(Sheets.Count).Range("O1:E" & numRows), _
order1:=xlAscending, Header:=xlYes
'Determine Number of Remaining Names in new sheet Column O
numNamesleft = Sheets(Sheets.Count).Cells(Rows.Count, _
"E").End(xlUp).Row - 1
'Determine 10% of total entries from Sheet1
percRows = _
WorksheetFunction.RoundUp((numRows - 1) * 0.2, 0)
'Determine how many extra rows are needed to reach 10% of total
unqNames = Sheets(2).Cells(Rows.Count, _
"E").End(xlUp).Row - 1
extRows = percRows - unqNames
'Warn user if number of Unique Names exceeds 10% of Total Entires
If extRows < 0 Then
MsgBox "Number of Unique Names Exceeds 10% of Total Entries"
'Delete new sheet
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
Exit Sub
End If
'Extract Random entries from remaining names to reach 10%
'
'Allocate elements in Array
ReDim MyRows(extRows)
'Create Random numbers and fill array
For nxtRow = 1 To extRows
getNewRnd:
'Generate Random row numbers within current Name Group
nxtRnd = Int((numNamesleft - 2 + 1) * _
Rnd + 2)
'Loop through array, checking for Duplicates
For chkRnd = 1 To nxtRow
'Get new number if Duplicate is found
If MyRows(chkRnd) = nxtRnd Then GoTo getNewRnd
Next
'Add element if Random number is unique
MyRows(nxtRow) = nxtRnd
Next
'Loop through Array, copying rows to Sheet2
For copyrow = 1 To extRows
dstRow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(Sheets.Count).Rows(MyRows(copyrow)).EntireRow.Copy _
Destination:=Sheets(2).Cells(dstRow, 1)
Next
'Delete new sheet
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
End Sub
you may try this (commented) code:
Option Explicit
Sub main()
Dim helpCol As Range, cell As Range
Dim resultSht As Worksheet
Set resultSht = GetOrCreateSheet("Results") '<--| change "Results" to your wanted name of the "output" sheet
With Worksheets("Decisions") '<--| change "Decisions" to your actual data sheet
With .Range("O1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference data from in columns "A:O" from row 1 down to last not empty row of column "A"
Set helpCol = .Resize(, 1).Offset(, .Parent.UsedRange.Columns(.Parent.UsedRange.Columns.Count).Column) '<-- set a "helper" column where to paste "names" and get unique ones only
helpCol.Value = .Resize(, 1).Offset(, 3).Value '<--| paste "names" values from column "D" (i.e. offseted 3 columns from column "A") to "helper" column
helpCol.RemoveDuplicates Columns:=Array(1), Header:=xlYes '<-- get only unique "names" in "helper" column
For Each cell In helpCol.Offset(1).SpecialCells(xlCellTypeConstants) '<-- loop through unique "names" in "helper" column
.AutoFilter field:=4, Criteria1:=cell.Value '<-- filter reference data on 4th column (i.e. column "D") with current "name"
Filter2AndWriteRandom .Cells, 5, "YES", 0.1, resultSht '<-- filter again on 5th column (i.e. column "E") with "YES" and write random 10% in "output" sheet
Filter2AndWriteRandom .Cells, 5, "NO", 0.1, resultSht '<-- filter again on 5th column (i.e. column "E") with "NO" and write random 10% in "output" sheet
Next cell
End With
helpCol.ClearContents '<-- clear "helper" column
.AutoFilterMode = False '<-- show all rows back
End With
End Sub
Sub Filter2AndWriteRandom(rng As Range, fieldIndex As Long, criterium As String, perc As Double, resultSht As Worksheet)
Dim nCells As Long, nPerc As Long, iArea As Long, iRow As Long, iArr As Long
Dim sampleRows() As Long
Dim filteredRows() As Long
With rng '<-- reference passed range
.SpecialCells(xlCellTypeVisible).AutoFilter field:=fieldIndex, Criteria1:=criterium '<-- filter on its passed 'filterIndex' column with passed 'criterium'
nCells = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 '<-- count filtered cells, skipping header one
If nCells > 0 Then '<-- if any cell filtered other than header one
ReDim filteredRows(1 To nCells) '<-- resize the array that will collect the filtered rows row index
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<-- reference filtered data only
For iArea = 1 To .Areas.Count '<-- loop through groups of cells into which data has been filtered down
For iRow = 1 To .Areas(iArea).Rows.Count '<-- loop through current 'Area' rows
iArr = iArr + 1 '<-- update filtered rows row index index
filteredRows(iArr) = .Areas(iArea).Rows(iRow).Row '<-- update filtered rows row index
Next iRow
Next iArea
End With
nPerc = WorksheetFunction.RoundUp(nCells * perc, 0) '<-- evaluate the number of rows to be randomly extracted
sampleRows = GetRandomSample(nCells, nPerc) '<-- get the array with randomly chosen rows index
For iRow = 1 To nPerc '<-- loop through number of rows to be randomly extracted
resultSht.Cells(resultSht.Rows.Count, 1).End(xlUp).Offset(1).Resize(, .Columns.Count).Value = .Rows(filteredRows(sampleRows(iRow))).Value '<-- update "output" sheet
Next iRow
End If
End With
End Sub
Function GetRandomSample(ByVal nNumbers As Long, nSamples As Long) As Long()
Dim numbers() As Long
Dim iSample As Long, i As Long
ReDim rndNumbers(1 To nSamples) As Long
numbers = GetNumbers(nNumbers)
For iSample = 1 To nSamples
i = Int((nNumbers * Rnd) + 1)
rndNumbers(iSample) = numbers(i)
numbers(i) = numbers(nNumbers)
nNumbers = nNumbers - 1
Next iSample
GetRandomSample = rndNumbers
End Function
Function GetNumbers(nNumbers As Long) As Long()
ReDim numbers(1 To nNumbers) As Long
Dim i As Long
For i = 1 To nNumbers
numbers(i) = i
Next i
GetNumbers = numbers
End Function
Function GetOrCreateSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateSheet = Worksheets(shtName)
If GetOrCreateSheet Is Nothing Then
Set GetOrCreateSheet = Worksheets.Add
ActiveSheet.Name = shtName
End If
End Function
user3598756 I HAVE DONE something HERE CAN YOU MAKE ANY CHANGE SO THAT IF VALUE= NO DEFECT THAN COPY ONLY 10% FROM the row which has same user and decision.
Sub test()
Dim lr As Long, lr2 As Long, R As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Sheets(2).Cells.ClearContents
n = 1
lr = ws1.Cells(Rows.Count, "D").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "E").End(xlUp).Row
For R = 2 To lr
If Range("D" & R).Value = "gadrooa" And Range("E" & R).Value = "NO_DEFECT" Then
Rows(R).Copy Destination:=ws2.Range("A" & n + 1)
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
End If
Next R
Application.ScreenUpdating = True
End Sub
Related
I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA
I am being providing two contact lists as CSVs. List 2 is a new export. List 1 is from a week prior. However, List 2 includes the contacts from List 1.
This is not a matter of "Remove Duplicates" because I want to extract only the unique rows.
I have List 1 in Sheet1. I have List 2 in Sheet2. Sheet3 is empty. I need to compare Column 3 (email address) in List 1 to Column 3 (email address) in List 2 and EntireRow.Copy where Column 3 is unique, i.e. it appears ONLY in List 2, NOT in List 1.
I am no stranger to conditional logic, but I've never used Excel Macros / VBA like this. I was able to find a solution (see "2nd code") to export duplicates to a new sheet, and tried to modify it to export uniques, but I wasn't able to make it work.
EDIT 1
This is the code I modified from the aforementioned answer.
Option Explicit
Sub FilterAndCopy2()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range, _
unionRng As Range
Dim i As Long, iOld As Long
Set wstSource = Worksheets("DUPLICATE LIST FILTER")
Set wstOutput = Worksheets("UNIQUE LIST RESULTS")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wstSource
Set rngMyData = .Range("A1:K" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
With rngMyData
Set helperRng = .Offset(, rngMyData.Columns.Count - 1).Resize(, 1)
Set unionRng = .Cells(1000, 1000) 'set a "helper" cell to be used with Union method, to prevent it from failing the first time
End With
With helperRng
.FormulaR1C1 = "=row()" 'mark rows with ad ascending number (its own row number)
.Value = .Value
End With
With rngMyData.Resize(, rngMyData.Columns.Count + 1) 'enclose "helper" column
.Sort key1:=.Columns(10), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data to have all same columnA values grouped one after another
i = .Rows(1).Row 'start loop from data first row
Do While i < .Rows(.Rows.Count).Row
iOld = i 'set current row as starting row
Do While .Cells(iOld + 1, 1) = .Cells(iOld, 1) 'loop till first cell with different value
iOld = iOld + 1
Loop
If iOld - i = 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
i = iOld + 1
Loop
Intersect(unionRng, rngMyData).EntireRow.Copy Destination:=wstOutput.Cells(1, 1) 'get rid of the "helper" cell via Intersect method
wstOutput.Columns(helperRng.Column).Clear 'delete "Helper" column pasted in wstOutput sheet
.Sort key1:=.Columns(10), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data in wstSource back
End With
helperRng.Clear 'delete "helper" column, not needed anymore
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The result is not comparing the Email column. I found a known duplicate in my data, and modified the email address. The row was not exported to the target Sheet.
NOTE: This in-progress solution does not use 3 separate sheets as I described above, only two.
Code below is assuming you don't need to actually copy/paste the row but rather transfer the value in the result sheet.
Sub find_unique()
Application.ScreenUpdating = False
Dim Wb As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim P1 As Range, P2 As Range, a As Integer
Set Wb = Workbooks("unique.xlsm")
Set Sh1 = Wb.Sheets(1) ' Adapt to original list
Set Sh2 = Wb.Sheets(2) ' Adapt to updated list
Set Sh3 = Wb.Sheets(3) ' Adapt to destination sheet
Set P1 = Sh1.UsedRange
Set P2 = Sh2.UsedRange
Set D1 = CreateObject("scripting.dictionary")
T1 = P1
For i = 2 To UBound(T1)
D1(UCase(T1(i, 1))) = UCase(T1(i, 1)) 'Change 1 for the column number of your unique identifier
Next i
T2 = P2
a = 1
Dim T3()
For i = 1 To UBound(T2)
If i = 1 Then 'Considering you have headers
ReDim Preserve T3(1 To UBound(T2, 2), 1 To a)
For j = 1 To UBound(T2, 2)
T3(j, a) = T2(i, j)
Next j
a = a + 1
Else
If Not D1.exists(UCase(T2(i, 1))) Then 'Change 1 for the column number of you unique identifier
ReDim Preserve T3(1 To UBound(T2, 2), 1 To a)
For j = 1 To UBound(T2, 2)
T3(j, a) = T2(i, j)
Next j
a = a + 1
End If
End If
Next i
Sh3.Cells.Clear 'Assuming you want to replace the result in sheet(3) each time
Sh3.Range("A1").Resize(UBound(T3, 2), UBound(T3, 1)) = Application.Transpose(T3)
Application.ScreenUpdating = True
End Sub
Other option if you really want to copy/paste the unique row :
Sub find_unique2()
Application.ScreenUpdating = False
Dim Wb As Workbook, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim P1 As Range, P2 As Range, a As Integer
Set Wb = Workbooks("unique.xlsm")
Set Sh1 = Wb.Sheets(1) ' Adapt to original list
Set Sh2 = Wb.Sheets(2) ' Adapt to updated list
Set Sh3 = Wb.Sheets(3) ' Adapt to destination sheet
Set P1 = Sh1.UsedRange
Set P2 = Sh2.UsedRange
Set D1 = CreateObject("scripting.dictionary")
T1 = P1
For i = 2 To UBound(T1)
D1(UCase(T1(i, 1))) = UCase(T1(i, 1)) 'Change 1 for the column number of your unique identifier
Next i
T2 = P2
a = 2
Sh3.Cells.Clear
For i = 1 To UBound(T2)
If i = 1 Then 'Considering you have headers
Sh2.Rows(1).Copy Sh3.Rows(1)
Else
If Not D1.exists(UCase(T2(i, 1))) Then 'Change 1 for the column number of you unique identifier
Sh2.Rows(i).Copy Sh3.Rows(a)
a = a + 1
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Looking to match values of column 1&2 of the same row on sheet2 to values of column 1&2 of the same row on sheet1. Then, copy entire row of sheet1 match onto next blank row of sheet3 + copy value of column 3+4 of same row sheet2 onto end of pasted row on sheet3.
IF Sheet2 Row First&Last (column1&2) Name match Sheet1 Row First&Last (column1&2)
THEN
Copy Sheet1 Row, paste to Sheet3 # next blank Row. Copy Sheet2 Row column 3+4 # end of previously pasted Row on Sheet3
Here is what I have so far, this doesn’t do anything right now but I have pieced it together from a few working macros to try and accomplish what I’m after. I haven’t been able to find examples of “Copy Sheet2 Row column 3+4 # end of previously pasted Row on Sheet3” so I just have a description on the line where I think the code should go.
Sub Match_Copy_AddValues()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Set s1 = ActiveSheet 'List with dump data'
Set s2 = Sheets("Sheet 2") 'List of names to match, and additional information to be added'
Set s3 = Sheets("Sheet 3") 'Worksheet to copy rows of matched names'
Dim r As Long 'Current Row being matched?'
On Error GoTo fìn
Set ws2 = Sheets("Sheet 2")
With Sheets("Sheet 1")
r = Application.Max(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(Rows.Count, 2).End(xlUp).Row) 'Defines # of rows to apply If/Then to?'
For r = Application.Sum(v) To 2 Step -1 'Each time If/Then is ran, reduce # of rows to apply If/Then to?'
If CBool(Application.CountIfs(ws2.Columns(1), .Cells(r, 1).Value, ws2.Columns(2), .Cells(r, 2).Value)) Then _
.Rows(r).EntireRow.Copy s3.Cells(K, 1) 'Compares value in (r)row column 1 and 2, sheet2, to sheet1(activesheet), if equal THEN copies entire (r)row onto sheet3 # next empty row'
'take (r)row of match and copy value of column 3 and 4 sheet2 onto the end of previously pasted row on sheet3'
Next r
End With
fìn:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The code below doesn't do everything just the way your attempt suggests but I wrote it in very plain language so that you will surely be able to teak it back into your track where it has transgressed to where it shouldn't go.
Sub MatchNameAndInfo()
' 02 Aug 2017
Dim WsInput As Worksheet
Dim WsInfo As Worksheet
Dim WsOutput As Worksheet
Dim Rl As Long ' Last row of WsInput
Dim R As Long ' WsInput/WsInfo row counter
Dim Tmp1 As String, Tmp2 As String ' Clm 1 and Clm2 Input values
Dim Cmp1 As String, Cmp2 As String ' Clm 1 and Clm2 Info values
Set WsInput = Worksheets("Krang (Input)")
Set WsInfo = Worksheets("Krang (Info)")
Set WsOutput = Worksheets("Krang (Output)")
Application.ScreenUpdating = False
With WsInput
Rl = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(.Rows.Count, 2).End(xlUp).Row)
If Rl < 2 Then Exit Sub
For R = 2 To Rl ' define each input row in turn
Tmp1 = Trim(.Cells(R, 1).Value)
Tmp2 = Trim(.Cells(R, 2).Value)
Cmp1 = Trim(WsInfo.Cells(R, 1).Value)
Cmp2 = Trim(WsInfo.Cells(R, 2).Value)
If StrComp(Tmp1 & Tmp2, Cmp1 & Cmp2, vbTextCompare) = 0 Then
TransferData R, WsInfo, WsOutput
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Function TransferData(R As Long, _
WsInfo As Worksheet, _
WsOut As Worksheet)
' 02 Aug 2017
Dim Rng As Range
Dim Rt As Long ' target row
With WsInfo
Set Rng = .Range(.Cells(R, 1), .Cells(R, 4))
End With
With WsOut
Rt = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 2)
Rng.Copy Destination:=.Cells(Rt, 1)
End With
End Function
I am trying to copy rows that contain data (in cells A, B, C, D) down into the same cells (in the different rows) if the cells are blank. So basically copying the data in the above cells if the preceding cells are empty. The code I have is as follows:
Sub PadOut()
With Range("A2:D300") ' change this
On Error Resume Next
Set aRange = .SpecialCells(xlCellTypeBlanks) 'check for blank cells
On Error Goto 0
If Not aRange Is Nothing Then
aRange.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End If
End With
End Sub
Currently I have it at a set range.. But how can I set so as the range can be expanded (if I didn't know the number of total rows)
Is this what you're trying to achieve? You can change the start row and column number as neccessary. The endCol variable defines the last colulmn to scan through and the endRow loop finds the last used row in the defined column range.
Sub PadOut()
Application.ScreenUpdating = False
Dim startRow As Long
startRow = 2
Dim startCol As Long
startCol = 1
Dim endCol As Long
endCol = 3
With ActiveSheet
Dim row As Long
Dim col As Long
Dim endRow As Long
Dim bottomRow As Long
bottomRow = ActiveSheet.Rows.Count
Dim colEndRow As Long
endRow = 0
For col = startCol To endCol
If (Cells(bottomRow, col).End(xlUp).row > endRow) Then
endRow = Cells(bottomRow, col).End(xlUp).row
End If
Next col
For col = startCol To endCol
For row = startRow + 1 To endRow
If .Cells(row, col).value = "" Then
.Cells(row, col).value = .Cells(row - 1, col).value
End If
Next row
Next col
End With
Application.ScreenUpdating = True
End Sub
Sub PadOut()
lastRow = ActiveSheet.UsedRange.Rows.Count
if cells(lastRow, 1) = "" and cells(lastRow, 2) = "" and cells(lastRow, 3) = "" and cells(lastRow, 4) = "" then
lastRow = WorksheetFunction.Max(cells(lastRow, 1).end(xlup).row, cells(lastRow, 2).end(xlup).row, cells(lastRow, 3).end(xlUp).row, cells(lastRow, 4).end(xlup).row)
end if
With Range("A2:D" & lastRow)
On Error Resume Next
Set aRange = .SpecialCells(xlCellTypeBlanks) 'check for blank cells
On Error Goto 0
If Not aRange Is Nothing Then
aRange.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End If
End With
End Sub
You can get the total number of rows using the following:
numberRows = ActiveSheet.UsedRange.Rows.Count
Then you can set up the range accordingly.
You don't really need VBA for this task.
It can be accomplished with use of the selection page and array filling.
To do this:
Highlight your range, starting with the first row and cell that has blank data you are interested in filling.
Next, press CTRL+G, this will display the "Go To" window, press Special.... Select the "blanks" option and press OK.
This will select all BLANK cells in your range. Then, without clicking (or you will change your selection), type: = {Press UP arrow} then press CTRL + ENTER
Your Data Before // Your Data After
I have an excel which has 3 sheets. In sheet 1 and 2 i have approximately 10 columns each but has different total number of rows. I want to check if data in Sheet 2 is in Sheet 1. If it has a match then do nothing but if it has no match then copy the entire row into sheet 3.
Here's my code But I think i got it wrong
Sub test()
Dim rng As Range, c As Range, cfind As Range
On Error Resume Next
Worksheets("sheet3").Cells.Clear
With Worksheets("sheet1")
Set rng = Range(.Range("A2"), .Range("a2").End(xlDown))
For Each c In rng
With Worksheets("sheet2")
Set cfind = .Columns("A:A").Cells.Find _
(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then GoTo line1
'c.EntireRow.Copy Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
c.Copy Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
c.Offset(0, 2).Copy Worksheets("sheet3").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
End With 'sheet 2
line1:
Next c
Application.CutCopyMode = False
End With 'sheet 1
To explain it in picture refer below
Sheet 1
Sheet 2
Sheet 3
The Sheet 3 is my expected output. Can i obtain the output such as that.
Please help.
Thanks.
Try this one "
Sub test()
Dim rng As Range, c As Range, cfind As Range
On Error Resume Next
Worksheets(3).Cells.Clear
With Worksheets(1)
Set rng = .Range(.Range("A2"), .Range("a2").End(xlDown)) 'added . (dot) in front of first range
For Each c In rng
With Worksheets(2)
Set cfind = .Columns("A:A").Cells.Find _
(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then
'change the "10" in "Resize(1, 10)" to the number of columns you have
c.Resize(1, 10).Copy Worksheets(3).Cells(Worksheets(3).Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
End With 'sheet 2
Next c
Application.CutCopyMode = False
End With 'sheet 1
End Sub
Edit for Avidan's question in comments
To check every row with every row on other sheet requires different approach. Such as :
Sub CopyMissingRecords()
'compare whole record in row on 1st worksheet with all records in rows on 2nd worksheet
'and if there is no such row in the 2nd worksheet, then copy the missing record to 3rd worksheet
'repeat for all records on 1st worksheet
Dim varToCopy() As Variant
Dim varToCompare() As Variant
Dim intCopyRow As Integer
Dim intCopyRowMax As Integer
Dim intToCompareRow As Integer
Dim intToCompareRowMax As Integer
Dim bytColumnsInData As Byte
Dim intMisMatchCounter As Integer
Dim intComparingLoop As Integer
Dim intRowMisMatch As Integer
bytColumnsInData = 10 ' change to your situation
'clear everything in our output columns in Worksheets(3)
With Worksheets(3)
.Range(.Cells(2, 1), .Cells(.Rows.Count, bytColumnsInData)).Clear
End With
With Worksheets(1)
'last row in Worksheets(1)
intCopyRowMax = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
'compare each row in Worksheets(1)
For intCopyRow = 2 To intCopyRowMax
'store the first row record from Worksheets(1) into memory
ReDim varToCopy(0)
varToCopy(0) = .Range(.Cells(intCopyRow, 1), .Cells(intCopyRow, bytColumnsInData))
With Worksheets(2)
'last row in Worksheets(2)
intToCompareRowMax = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
'loop through all rows in Worksheets(2)
For intToCompareRow = 2 To intToCompareRowMax
'store the actual row record from Worksheets(2) into memory
ReDim varToCompare(0)
varToCompare(0) = .Range(.Cells(intToCompareRow, 1), .Cells(intToCompareRow, bytColumnsInData))
'compare each column from the row record in Worksheets(1), with each column from the row record in Worksheets(2)
For intComparingLoop = 1 To bytColumnsInData
'if any of the cells from Worksheets(1) in compared row are different than cells from Worksheets(2) in compared row
'just one difference in row is enough to consider this record as missing
If varToCopy(0)(1, intComparingLoop) <> varToCompare(0)(1, intComparingLoop) Then
'store how many row MisMatches are there in data
intRowMisMatch = intRowMisMatch + 1
Exit For
End If
Next intComparingLoop
Next intToCompareRow 'next row in Worksheets(2)
'if there are as many row mismatches as there are row records in Worksheets(2)
If intRowMisMatch = intToCompareRowMax - 1 Then
With Worksheets(3)
'copy the entire row from Worksheets(1) to the next available row in Worksheets(3)
Worksheets(1).Range(Worksheets(1).Cells(intCopyRow, 1), Worksheets(1).Cells(intCopyRow, bytColumnsInData)).Copy _
Destination:=.Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With 'Worksheets(3)
End If
'reset the counter
intRowMisMatch = 0
End With 'Worksheets(2)
Next intCopyRow 'next row in Worksheets(1)
End With 'Worksheets(1)
End Sub