I have created a pivot table with Column A and Column B.
Column A has one to many relation with Column B.
I want to highlight Column A, if there is a difference in Column B values in its scope. For example,
A B
ABC 10
10
XYZ 20
25
In this case, XYZ has 2 different values in column B. I want to highlight this. How can this be done in excel?
Cheers!!
Here is how you can do it with VBA
Private Sub CommandButton8_Click()
Dim WS As Excel.Worksheet
Dim lRow As Long
Dim lastRow As Long
Dim ValueB As String
Dim lRowA As Long
Set WS = Application.Sheets("Sheet1")
lRow = 1
'Get the last row that has data in columnB
lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
'Loop through all the rows
Do While lRow <= lastRow
'If we have data in columnA, record it
If WS.Range("A" & lRow).Value <> "" Then
ValueB = WS.Range("B" & lRow).Value
'Keep track of the row that we found new columnA data on
lRowA = lRow
Else
'We don't have data in columnA, Compare what we found in
'columnB of the last row where we had data in columnA with this row
If ValueB <> WS.Range("B" & lRow).Value Then
WS.Range("A" & lRowA).Interior.Pattern = xlSolid
WS.Range("A" & lRowA).Interior.PatternColorIndex = xlAutomatic
WS.Range("A" & lRowA).Interior.Color = 255
End If
End If
lRow = lRow + 1
WS.Range("A" & lRow).Activate
Loop
End Sub
Related
I want to get a sum based on the criteria of the preceding column data. Suppose I have three columns say A, B and C. So, "A" columns have the Sr.no. let's say, "B" has the quantity and "C" have the total quantity. I am trying to sum the quantity in column "B" based on the Sr.no. in column "A" and paste it to column "C" (after merging that many cells) against the respective Sr.no. (Which we have in column "A"). Refer image attached Image.
Sub sum_on_condition()
Dim sum_criteria As Double
Dim lastrow As Long, x As Long
Dim l_array As Variant
Dim l_number As Long
lastrow = range("A" & Rows.Count).End(xlUp).Row
l_array = range("I2:I21").Value
counter = 1
While counter <= UBound(l_array)
l_number = l_array(counter, 1)
For x = 2 To lastrow
If range("e" & x).Value = l_number Then
sum_criteria = sum_criteria + range("f" & x).Value
End If
Next x
counter = counter + 1
Wend
Debug.Print sum_criteria
End Sub
I have written this code but what it does it sums the total value rather than the individual value. I am not able to figure out how I do this!
Here's another approach:
Sub SumAndMerge()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim firstItem As Long, lastItem As Long
Dim i As Long, j As Long
Dim c As Range, d As Range
Dim valueToFind As String
Dim total As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
'Get valueToFind
valueToFind = ws.Cells(i, 1).value
'Get range of cells with .Find : look up for first value and last value and get row number.
With ws.Range("A" & i & ":" & "A" & lastRow)
Set c = .Find(valueToFind, LookAt:=xlWhole)
firstItem = c.Row - 1
Set d = .Find(valueToFind, LookAt:=xlWhole, SearchDirection:=xlPrevious)
lastItem = d.Row
End With
'Get total
total = WorksheetFunction.Sum(ws.Range("B" & firstItem & ":" & "B" & lastItem))
'Assign total to first cell
ws.Range("C" & firstItem).value = total
'Merge cells
ws.Range("C" & firstItem & ":" & "C" & lastItem).Merge
'Go to lastItem to adapt the loop
i = lastItem
Next i
End Sub
Gives the following output:
Rather than using an array, this macro aims at using the Find function. In a loop, we find the first value and the last value. We extract row numbers and then we can assign the total and finally merge cells.
This code can be improved by replacing harcoded A, B and C. But this gives you an example.
I want to fill each empty cells of a board with a precise range of data.
I 've got two worksheets;
-worksheets("Board")
- worksheets("FinalBoard")
In worksheet worksheets("Board") I've got the following board ;
Category
Fruits-1
Fruits-2
Fruits-3
A
Banana
Cherries
Orange
D
Apple
Mango
Strawberries
B
Pineapple
Watermelon
Grenade
I want to pick each columns data only if the header starts with "Fruits" and paste them in one colum in worksheet worksheets("FinalBoard") . I was able to do so with columns named Fruits, with the following code;
Sub P_Fruits()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim n As Long
Dim s As String
Dim col As String
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1, i).Value2 Like "Fruit-*" Then
'~~> Get columns name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> Copy-paste in the 2nd worksheet every data if the headers is found
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("B" & lRowOutput)
End If
Next i
end with
end sub
however I'd like to do so for the column "category" and put the category's type in front of each fruits in column A and thus repeat the copied range category multiple time , as much as there were headers beginning with "Fruits" in worksheets("Board") . I tried to add an extra code to the previous one but it didnt work. Here is what I'd like as a result;
Category-pasted
Fruits-pasted
A
Banana
D
Apple
B
Pineapple
A
Cherries
D
Melon
B
Watermelon
A
Orange
D
Strawberries
B
Grenade
Here is what I had with the code I added instead...
Category-pasted
Fruits-pasted
Banana
Apple
Pineapple
Cherries
Melon
Watermelon
Orange
Strawberries
Grenade
A
D
B
My finale code;
Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim n As Long
Dim s As String
Dim col As String
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1, i).Value2 Like "Fruit-*" Then
'~~> Get column name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> Copy-paste
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("B" & lRowOutput)
End If
Next i
'Code to repeat category type added
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
'~~> research criterias
If .Cells(1, i).Value2 Like "Category*" Then
'~~> Get column name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("A" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> copy-paste each category type in column A
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("A" & lRowOutput)
End If
Next i
End With
End With
I feel like I'm close to the solution. I'd appreciate your help guys, thank you!
This code will produce the required results but uses a different approach.
The first thing it does is read the source data into an array, it then goes through that array and extracts the fruits/categories from every column with a header starting with 'Fruit.
Option Explicit
Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim arrDataIn As Variant
Dim arrDataOut As Variant
Dim idxCol As Long
Dim idxRow As Long
Dim cnt As Long
'~~> Sheets settings
Set wsInput = Sheets("Board")
Set wsOutput = Sheets("FinalBoard")
' assumes data on 'Board' starts in A1
With wsInput
arrDataIn = .Range("A1").CurrentRegion.Value
End With
ReDim arrDataOut(1 To 2, 1 To UBound(arrDataIn, 1) * UBound(arrDataIn, 2))
For idxCol = LBound(arrDataIn, 2) To UBound(arrDataIn, 2)
If arrDataIn(1, idxCol) Like "Fruits*" Then
For idxRow = LBound(arrDataIn, 1) + 1 To UBound(arrDataIn, 1)
cnt = cnt + 1
arrDataOut(1, cnt) = arrDataIn(idxRow, 1)
arrDataOut(2, cnt) = arrDataIn(idxRow, idxCol)
Next idxRow
End If
Next idxCol
If cnt > 0 Then
ReDim Preserve arrDataOut(1 To 2, 1 To cnt)
End If
With wsOutput
.Range("A1:B1").Value = Array("Category-pasted", "Fruit-pasted")
.Range("A2").Resize(cnt, 2) = Application.Transpose(arrDataOut)
End With
End Sub
As I explained in my comments you don't need the second loop if you already found the correct row - get the category column early and reuse it later
You can add this variable declaration at the top first
Dim col As String
Then continue with your code for first loop (deleting second loop
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> loop through columns
For i = 1 To lCol
Add this to retrieve categories first
If .Cells(1, i).Value2 Like "Category*" Then
'~~> Get column name
colCat = Split(.Cells(, i).Address, "$")(1)
End If
'~~> research criterias
If .Cells(1, i).Value2 Like "Fruit-*" Then
'~~> Get column name
col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .range(col & .Rows.Count).End(xlUp).row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
End If
'~~> Copy-paste
.range(col & "2:" & col & lRowInput).Copy _
wsOutput.range("B" & lRowOutput)
Then add this to paste the categories
'~~> copy-paste each category type in column A
.range(colCat & "2:" & colCat & lRowInput).Copy _
wsOutput.range("A" & lRowOutput)
End If
Next i
End With
Been searching like crazy but can't find exactly what I'm looking for.
Column A: Some employees (Partial List)
Column E: All employees (Complete List)
I need Column C to be populated with all other employees not in Column A (Column A compared to Column E to pull data into Column C that is not in Column A).
I have tried IF, VLOOKUP functions and have come close but don't want any blank cells in Column C.
I would prefer a VBA code (as column A and C are linked to an external datasource) and are populated using VBA.
Thanks in advance!
Try this:
Sub test()
Dim LastRowA As Long
Dim LastRowC As Long
Dim LastRowE As Long
Dim i As Long
Dim j As Long
Dim NameNotExist As Boolean
LastRowA =Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
LastRowC = Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row
LastRowE = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row
For i = 1 To LastRowE
For j = 1 To LastRowA
NameNotExist = False
If Sheet1.Range("E" & i).Value =Sheet1.Range("A" & j).Value Then
Exit For
Else
NameNotExist = True
End If
Next j
If NameNotExist = True Then
If LastRowC = 1 And Sheet1.Range("C1").Value = "" Then
Sheet1.Range("C1").Value =Sheet1.Range("E" & i).Value
Else:
LastRowC =Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row
Sheet1.Range("C" & LastRowC + 1).Value = Sheet1.Range("E" & i).Value
End If
End If
Next i
End Sub
I need a macro to write the row values present in column A if there is a value present in column B .
For example :
Column A Column B
Arjun
Arun 12
For the above example, I need a macro which can write "Arun 12" in Sheet2 of the work book with the Headers "Name" and "Hours".Before this the macro should clear the data present in Sheet two completely.
This will copy the all rows of columns A and B from Sheet1 to Sheet2 if B is not a Null string. And also will add the headers "Name" and "Hours".
Option Explicit 'requires that every variable has to be defined before use, e.g. with a Dim statement.
Sub DoStuff_GoodPractice()
Dim lastRowSrc As Long, lastRowDest As Long, i As Long 'declare row counts as Long so all rows can be used
Dim shtSource As Worksheet, shtDestination As Worksheet
Set shtSource = ThisWorkbook.Worksheets("Sheet1") 'full qualified identification of the worksheets
Set shtDestination = ThisWorkbook.Sheets("Sheet2")
lastRowSrc = shtSource.Range("A" & shtSource.Rows.Count).End(xlUp).Row 'determine the last used row
'clear destination sheet and write headers:
shtDestination.Cells.Clear
shtDestination.Range("A1").Value = "Name"
shtDestination.Range("B1").Value = "Hours"
lastRowDest = 1 'start with row 1 as destination
For i = 1 To lastRowSrc 'loop through all used rows
If shtSource.Range("A" & i).Value <> vbNullString And _
shtSource.Range("B" & i).Value <> vbNullString Then 'check if cells are not a null string
shtSource.Range("A" & i & ":B" & i).Copy Destination:=shtDestination.Range("A" & lastRowDest + 1) 'copy current row
lastRowDest = lastRowDest + 1 'jump to the last used row in destination
End If
Next i
End Sub
This should accomplish what you're after.
Sub DoStuff()
Dim lastRow As integer, lastRowSheet2 As integer, i As Integer
Dim sheet1 As WorkSheet, sheet2 As Worksheet
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
lastRow = sheet1.Range("A" & Rows.Count).End(xlUp).Row
sheet2.Cells.Clear
For i = 1 To lastRow
If sheet1.Range("A" & i).Value <> "" And sheet1.Range("B" & i).Value <> "" then
lastRowSheet2 = sheet2.Range("A" & Rows.Count).End(xlUp).Row
sheet1.Range("A" & i & ":B" & i).Copy Destination:= sheet2.Range("A" & lastRowSheet2 + 1)
End If
Next i
End Sub
I am writing to column C, but the data goes ex: C1:X1, instead I would like it by row. (ex: C1:C25) I would like it to be transposed vertically down the rows instead of horizontally.
The problem with this is I want the columns A&B to be filled down with this transposition in unisen. So A1:A25 would have the file name and C1:c25 would have my headers.
As I start to add more columns I would like to be able to add more columns and fill down to these aswell. (only filldown columns A and B)
any Ideas?
Code:
Dim iIndex As Integer
Dim lCol As Long
Dim lOutputCol As Long
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.Count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.Name
wsReport.Range("B" & lRow).Value = ws.Name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the header
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
Function:
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
You should just be able to change the lOutputCol from an incremented value to a static columnC. And you will have to add a lRow count increment inside the loop.
Change
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the headers
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
to
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.Name
wsReport.Range("B" & lRow).Value = ws.Name
'Write the headers
wsReport.Range("C" & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
'Increment the row we are writing to
lRow = lRow + 1
Next lCol