i am trying to populate 4 coulms and 130 rows from b2:b130 in display sheet using vlookup from bills sheet using rowid i created.
my data as in attached image.if anyone can help me with this that will be great.
Try the next code, please. It should be very fast and does not increase the workbook size like in case of formulas:
Sub copyRangeForSpecRows()
Dim firstRow As Long, lastRow As Long, shS As Worksheet, shD As Worksheet, El As Variant
Dim arrEX As Variant, arrGY As Variant, arrIZ As Variant, arrKAA As Variant
Dim pasteRow As Long, lastCopyRow As Long, arrRows As Variant, i As Long, k As Long
Set shS = Sheets("Bills") 'use here your sheet to copy from
Set shD = Sheets("Display")
firstRow = 5: lastRow = 130
pasteRow = CLng(shD.Range("T" & firstRow).Value)
lastCopyRow = CLng(shD.Range("T" & firstRow + lastRow).Value)
ReDim arrEX(1 To lastRow, 1 To 1): ReDim arrGY(1 To lastRow, 1 To 1)
ReDim arrIZ(1 To lastRow, 1 To 1): ReDim arrKAA(1 To lastRow, 1 To 1)
arrRows = shD.Range(shD.cells(firstRow, "T"), shD.cells(lastRow + firstRow - 1, "T")).Value
For i = pasteRow To lastCopyRow
For Each El In arrRows
If i = CLng(El) Then
k = k + 1
arrEX(k, 1) = shS.Range("X" & i).Value
arrGY(k, 1) = shS.Range("Y" & i).Value
arrIZ(k, 1) = shS.Range("Z" & i).Value
arrKAA(k, 1) = shS.Range("AA" & i).Value
End If
Next
Next i
shD.Range("E5:E" & 4 + lastRow).Value = arrEX
shD.Range("G5:G" & 4 + lastRow).Value = arrGY
shD.Range("I5:I" & 4 + lastRow).Value = arrIZ
shD.Range("K5:K" & 4 + lastRow).Value = arrKAA
MsgBox "Ready..."
End Sub
Based on how small scale this is and where you said you are just a starter with vba, I kept it simple(ish) while getting the desired result.
Commented for understanding.
Option Explicit
Sub populateData()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsDisp As Worksheet: Set wsDisp = wb.Worksheets("Display")
Dim wsBill As Worksheet: Set wsBill = wb.Worksheets("Bills")
Dim LastRow As Long
Dim i As Long
LastRow = wsDisp.Cells(wsDisp.Rows.Count, "B").End(xlUp).Row ' finds the last row in column B of the "Display" worksheet
On Error Resume Next ' bypasses errors such as unmatched values
For i = 1 To LastRow ' loop until the last row containing data
wsDisp.Cells(i, 5).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 24) ' populates "GIDC Gas Paid" row in "Display" worksheet
wsDisp.Cells(i, 7).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 25) ' populates "GST-GIDC Gas Paid" row in "Display" worksheet
wsDisp.Cells(i, 9).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 26) ' populates "GIDC Booking Paid" row in "Display" worksheet
wsDisp.Cells(i, 11).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 27) ' populates "GST-GIDC Booking Paid" row in "Display" worksheet
Next i ' iterates to the next number in the loop
End Sub
You should use index and Match function instead of Vlookup and if you want hard code then i will suggest you that go from row 1 to lastrow and check if both Sr.No and RowId match then take that data into an array and at the last paste the array data in Display Sheet.
Related
I apologize for the vague title as I'm not really sure where the error is. I think I'm having some compability issues with copying the elements of an array and then manipulating that data.
This is the code I have so far:
Sub listNotCompletedTasks()
Dim cell As Range
Dim sourceRange As Range
Dim targetRange As Range
Dim notCompleted() As Variant
Dim i As Integer
Dim lastr As Integer
'define sourceRange
lastr = Range("A" & Rows.count).End(xlUp).Row
Set sourceRange = Range("A2:A" & lastr)
'notCompleted is an array with all the offset cells of the cells in sourceRange
'that don't contain a "Completed" string
i = 0
For Each cell In sourceRange.Cells
If cell.Offset(0, 2).Value <> "Completed" Then 'if the cell in column C does not contain "completed"...
ReDim Preserve notCompleted(0 To i)
notCompleted(i) = cell.Value 'add cell in column A to array
i = i + 1
End If
Next cell
'define targetRange
lastRow = Cells(Rows.count, "Z").End(xlUp).Row
Set targetRange = Range("Z1:Z" & lastRow)
'copy all elements from the array to the targetRange
For i = 0 To UBound(notCompleted)
targetRange.Offset(i, 0).Value = notCompleted(i)
Next i
End Sub
Expected output:
This works well. The problem begins with the second step:
Sub listNoDuplicatesAndNoOfInstances()
Dim sourceRangeZ As Range
Dim targetRangeB As Range
Set sourceRangeZ = Sheets("SourceData").Range("Z2")
Set targetRangeB = Sheets("TargetSheet").Range("B17")
'add all of the unique instances of a string in Z from the notCompleted() array
Do Until IsEmpty(sourceRangeZ)
If Application.WorksheetFunction.CountIf(Sheets("TargetSheet").Range("B:B"), sourceRangeZ.Value) = 0 Then
targetRangeB.Value = sourceRangeZ.Value
Set targetRangeB = targetRangeB.Offset(1, 0)
Else
End If
Set sourceRangeZ = sourceRangeZ.Offset(1, 0)
Loop
'count every instance of those strings and add the value to the respective cell to the right
Set targetRangeB = Sheets("TargetSheet").Range("C17")
Do Until IsEmpty(targetRangeB.Offset(0, -1))
targetRangeB.Formula = "=COUNTIF(SourceData!Z:Z,Z" & targetRangeB.Row & ")"
Set targetRangeB = targetRangeB.Offset(2, 0)
Loop
End Sub
The first loop (the one that adds every unique instance of the strings to column B) works. The second loop (the one that returns the number of instances of each string) does not work, only returning zeroes. The thing is, if I manually do the steps of the first subroutine (use a Pivot Table to filter out the rows I need, then copy the relevant row and paste it to column Z), and then call the second subroutine, then it actually works!
So I'm assuming the first subroutine is the culprit. A "cheap" workaround that worked for me was to copy the range in Z to another column (using sourceRange.Copy/targetRange.PasteSpecial xlPasteAll) and then call the second subroutine. What am I doing wrong, and is there a better way to solve this?
A 2D array you can copy to sheet without looping.
Sub listNotCompletedTasks()
Dim wsSource As Worksheet, arNotCompl()
Dim lastrow As Long, i As Long, n As Long
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim arNotCompl(1 To lastrow, 1 To 1)
For i = 2 To lastrow
If .Cells(i, "C") <> "Completed" Then
n = n + 1
arNotCompl(n, 1) = .Cells(i, "A")
End If
Next
If n = 0 Then Exit Sub
'copy array to targetRange
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
.Cells(lastrow + 1, "Z").Resize(n) = arNotCompl
End With
End Sub
Add the formula in column C when you add the unique value to column B.
Sub listNoDuplicatesAndNoOfInstances()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lastrow As Long, i As Long, n As Long
Dim arNotCompl(), v
Set wsSource = ThisWorkbook.Sheets("SourceData")
With wsSource
lastrow = .Cells(.Rows.Count, "Z").End(xlUp).Row
arNotCompl = .Range("Z2:Z" & lastrow).Value2
End With
Set wsTarget = ThisWorkbook.Sheets("TargetSheet")
n = 17
With wsTarget
For i = 1 To UBound(arNotCompl)
v = arNotCompl(i, 1)
If Application.WorksheetFunction.CountIf(.Range("B:B"), v) = 0 Then
.Cells(n, "B") = v
.Cells(n, "C").Formula = "=COUNTIF(SourceData!Z:Z,B" & n & ")"
n = n + 1
End If
Next
End With
End Sub
Would anyone will be able to help me with this script please?
As it stand, this current macro separate the data once the value/text have changes and insert new row but I just cannot work it out how to include the headers once the row have been inserted.
Sub Insert Row()
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Set ws = Worksheets("Sheet1") 'the sheet with the data
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data in Column A
For i = lr - 1 To 2 Step -1
If ws.Range("A" & i).Value <> ws.Range("A" & i + 1).Value Then ws.Range("A" & i + 1).EntireRow.Insert
Next i
End Sub
Thank you in advanced.
Duplicate Headers
A Quick Fix
Sub InsertHeaders()
Const FIRST_ROW As Long = 1
Const EMPTY_ROWS As Long = 1
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim r As Long
For r = LastRow To FIRST_ROW + 2 Step -1
With ws.Cells(r, "A")
If .Value <> .Offset(-1).Value Then
.EntireRow.Resize(EMPTY_ROWS + 1).Insert
ws.Rows(1).Copy ws.Rows(.Row - 1)
End If
End With
Next r
End Sub
Please ignore my comment, as I just realize that it will be a different result if in column A there is a cell with the same value.
Example Data :
Expected result after running the sub :
Sub test()
Dim rgHdr As Range: Dim rgData As Range: Dim cell As Range
Dim i As Integer: Dim arr: Dim ins As Integer:dim sh as worksheet
Set sh = Sheets("Sheet1") 'change if needed
ins = 3 'change if needed
With sh
.Range("A1").EntireRow.Resize(ins).Insert Shift:=xlDown
Set rgHdr = .Range("A1").EntireRow.Resize(1 + ins)
Set rgData = .Range("K" & 2 + ins, .Range("K" & Rows.Count).End(xlUp))
End With
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgData: arr.Item(cell.Value) = 1: Next
For i = 1 To arr.Count - 1
rgHdr.Copy
sh.Cells(rgData.Find(arr.Keys()(i), _
after:=rgData.End(xlDown)).Row, 1).Insert Shift:=xlDown
Next
sh.Range("A1").EntireRow.Resize(ins).Delete
End Sub
sh = the sheets where the data is.
ins = skip how many blank rows.
The code use "insert copied cells" method, so it make three blank rows (the value of ins) before the header, then set the first three rows as rgHdr, set the rgData from K2 down to the last row with value.
arr = unique value in column K.
then it loop to each element in arr, get the first row occurence of the found cell which value is the looped element in arr, insert the copied rgHdr to that row.
Then finally it delete those three (ins value is 3) additional blank rows.
I need to auto number rows if adjacent cell is not blank using VBA.
any one from below codes works perfectly , except if it counter blank cells.
as always, your support is much appreciated.
this the expected output
Sub Fill_Serial_Numbers_Option1()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
Range("A3:A" & Application.Max(2, LastRow)) = Evaluate("ROW(A1:A" & LastRow & ")")
End If
End Sub
Sub Fill_Serial_Numbers_Option2()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
With Range("A3:A" & LastRow)
.Cells(1, 1).value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End If
End Sub
Please, test the next code:
Sub testCountNonBlanks()
Dim sh As Worksheet, lastR As Long, arr, arrA, count As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row: count = 1
If lastR <= 2 Then Exit Sub
arr = sh.Range("B2:B" & lastR).value 'place the range in an array for faster iteration
arrA = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then arrA(i, 1) = count: count = count + 1
Next i
sh.Range("A2").Resize(UBound(arrA), 1).value = arrA
End Sub
If a formula (written in VBA) is allowed, you can use the next variant:
Sub testCountByFormula()
Dim sh As Worksheet, lastR As Long, rngB As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
Set rngB = sh.Range("B2:B" & lastR)
sh.Range("A2:A10").Formula = "=IF(B2<>"""",COUNTA(" & rngB.Address & ")-COUNTA(" & rngB.Address(0, 1) & ")+1,"""")"
End Sub
You don't need a macro to accomplish this. Assuming all you care about is blank or not, then you can use a formula like this in cell A9. =Counta($B$1:$B9) If you have formulas you can try to leverage something with COuntif.
You can use a loop from the first row to the last one, something like this:
Sub Fill()
Dim LastRow As Long
Dim Count As Integer
Dim Row As Integer
Count = 0
Row = 1
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Do While Row <= LastRow
If Not (Cells(Row, 2) = "") Then
Count = Count + 1
Cells(Row, 1) = Count
End If
Row = Row + 1
Loop
End Sub
I need some help with comparing values from one column to another and delating it.
so far I have this:
Sub DelateDuplicates()
delArray = Sheets("Save").Range("B1:B") ' saved values
toDelate = Sheets("Validation").Range("B2:B").Value ' values to be checked and delated
lastRow = toDelate.Range("B1000").End(xlUp).Row ' last row
Firstrow = toDelate.Range("B2").End(xlDown).Row ' First row
Dim i As Long
For Lrow = lastRow To Firstrow Step -1
With Worksheets("Validation").Cells(Lrow, "A")
For i = 0 To UBound(delArray) ' arrays are indexed from zero
If Not IsError(.Value) Then
If .Value = delArray(i) Then
.EntireRow.Delete
Exit For
End If
End If
Next
End With
Next Lrow
End Sub
And I do have an error.
"1004 "Application-defined or Object-defined error" "
I have spent 2 days trying to figure it out so far no luck.
Any help will be appreciated.
I modified your code little bit. You can define your first rows and last row the want you want, I have kept it simple for the sake of concept
Option Explicit
Sub DelateDuplicates()
Dim Lrow As Long
Dim delarray()
With Worksheets("Save")
delarray = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Dim i As Long
Dim lastrow As Long
Dim firstrow As Long
firstrow = 1
With Worksheets("Validation")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = lastrow To firstrow Step -1
For i = 1 To UBound(delarray)
If Not IsError(.Cells(Lrow, "A").Value) Then
If .Cells(Lrow, "A").Value = delarray(i, 1) Then
.Cells(Lrow, "A").EntireRow.Delete
Exit For
End If
End If
Next i
Next Lrow
End With
End Sub
You can avoid loops within loops by using a Dictionary Object
Option Explicit
Sub DeleteDuplicates()
Dim wsSave As Worksheet, wsValid As Worksheet
Dim iLastRow As Long, iFirstRow As Long, i As Long, n As Long
Dim dict As Object, key, cell As Range
With ThisWorkbook
Set wsSave = .Sheets("Save")
Set wsValid = Sheets("Validation")
End With
Set dict = CreateObject("Scripting.Dictionary")
' get values to delete from Column B
For Each cell In wsSave.Range("B1", wsSave.Cells(Rows.Count, "B").End(xlUp))
key = Trim(cell)
If Len(key) > 0 Then
dict(key) = cell.Row
End If
Next
' scan Validation sheet and delete matching from Save
With wsValid
iFirstRow = .Cells(2, "B").End(xlDown).Row
iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = iLastRow To iFirstRow Step -1
key = .Cells(i, "A")
If dict.exists(key) Then
.Rows(i).Delete
n = n + 1
End If
Next
End With
' resutl
MsgBox n & " rows deleted between row " & _
iFirstRow & " and " & iLastRow, vbInformation
End Sub
I need a VBA code for copying the red colored cell content (its value), its and sheet name for that cell and Paste into in the new sheet in the workbook.
For Example there is Workbook having 3 sheets into it. And every sheet contains cells marked in red. I want to copy the cell text, cell address and sheet for this and Paste into the new sheet.
Please help on this.
This will do what you are looking for. Just using simple loops, first through the worksheets, then rows, then columns.
It will loop through all the worksheets in the workbook, exclude the master sheet, and examine the Interior color of the cell, and report to the Master sheet what the Sheet, Address, Value, Row, Columns are...
TESTED:
Sub ColorChecker()
Dim lastRow As Long
Dim lastCol As Long
Dim ws As Worksheet
Dim masterSheet As String
Dim mRow As Long
Dim lRow As Long
Dim lCol As Long
mRow = 2
masterSheet = "Master" 'Set the name of the Master Sheet
For Each ws In Worksheets
If ws.Name <> masterSheet Then
lastRow = Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).row
lastCol = Sheets(ws.Name).Cells(1, Columns.Count).End(xlToLeft).Column
For lRow = 2 To lastRow
For lCol = 1 To lastCol
If Sheets(ws.Name).Cells(lRow, lCol).Interior.ColorIndex = 3 Then
Sheets(masterSheet).Cells(mRow, 1) = ws.Name
Sheets(masterSheet).Cells(mRow, 2) = LongToRange(lRow, lCol)
Sheets(masterSheet).Cells(mRow, 3) = Sheets(ws.Name).Cells(lRow, lCol).Value
Sheets(masterSheet).Cells(mRow, 4) = lRow
Sheets(masterSheet).Cells(mRow, 5) = lCol
mRow = mRow + 1
End If
Next lCol
Next lRow
End If
Next ws
End Sub
This function will create a named Range based on your Column and Row numbers.
Function LongToRange(row As Long, col As Long) As String
Dim tempRange As String
tempRange = Chr(34) & ConvertToLetter(CInt(col)) & row & Chr(34)
LongToRange = tempRange
End Function
This function is from How to Convert Excel Column Numbers to Letters
Function ConvertToLetter(iCol As Integer) As String
'FROM support.microsoft.com/kb/833404
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function