Hi I am new in here so I still have many things to learn. Besides, I am not a native English-speaker, so it will be difficult for me to explain things. Anyways, I will try my best.
I am having issue with counting values based on multiple criteria. For example, I have two criteria which are "A" and "B". However, I only get the last value in each row. I have already used COUNTIFS but it still doesn't work.
Please take a look as below for better understanding of what I am doing.
Criteria | C | D | E | Criteria | C | D | E |
A | x | | x | A | 1 | | 1 |
B | | | x | --> B | | | 1 |
A | x | | |
Here is the code that I have so far.
Sub Run_Report()
Dim sht As Worksheet
Set sht = ActiveSheet
Dim wb As Workbook
Set wb = ThisWorkbook
Dim EndRow As Long
EndRow = wb.Sheets("MDR").Cells(Cells.Rows.Count, "C").End(xlUp).row
wb.Sheets("Report").Range("E9:N17").ClearContents
Dim LastCol As Long
For i = 9 To EndRow
LastCol = wb.Sheets("MDR").Cells(i, Columns.Count).End(xlToLeft).column
If LastCol > 5 And LastCol < 15 And wb.Sheets("MDR").Cells(i, LastCol).Font.ColorIndex = 3 Then
sht.Cells(9, wb.Sheets("MDR").Cells(i, LastCol).column).Value = Application.WorksheetFunction.CountIfs(wb.Sheets("MDR").Range("D9:D" & EndRow), "General", _
wb.Sheets("MDR").Range("A9:N" & EndRow).Columns(wb.Sheets("MDR").Cells(i, LastCol).column), "<>" & "")
End If
Next
End Sub
Any help will be appreciate.
Thanks!
Related
I know a little about vba, and I would like to achieve this using vba.
I am transferring data from sheet to another sheet with some special case.
Given this situation:
In another sheet I have these ranges
A4:B10
D2:E10
G2:H10
My data is something like this
AXX | Contact no.
AXX | Address
AXX | Name
AXX | Summary
BXX | Address
BXX | Name
BXX | Contact no.
BXX | Details
CXX | Address
CXX | Name
CXX | Summary
DXX | Address
DXX | Name
DXX | Contact no.
DXX | Address
DXX | Name
My identifier is in the first column (AXX, BXX...).
The expected output is:
Row no| Column A | Column B | Column D | Column E |
1 | | | | |
2 | | | BXX | Address |
3 | | | BXX | Name |
4 | AXX | Contact no. | BXX | Contact no. |
5 | AXX | Address | BXX | Details |
6 | AXX | Name | | |
7 | AXX | Summary | CXX | Address |
8 | | | CXX | Name |
9 | | | CXX | Summary |
10 | | | | |
As you could see, my identifiers are AXX, BXX... If they are similar I would count the no. of rows and compare it to the no. of rows in my set of ranges.
BXX was not placed next to AXX because the remaining row is 3 but BXX needs 4 so it will be passed on to the next range. Also there will be a blank cells separating other values as seen BXX and CXX.
For now, what I only know is to count the rows using For loop. Would like to seek your help for this thanks.
My Initial code to get row count
Dim aa, aaLastrow As Long
aaLastrow = ShtData.Range("A" & Rows.Count).End(xlUp).Row
For aa = 2 To aaLastrow
If ShtData.Cells(aa, 2).Value = ShtData.Cells(bb, 4).Value Then
Sheets("Sheet1").Cells(aa, 1).Value = ShtData.Cells(aa, 2).Value
End If
Next aa
I know my code is incorrect and I am not sure if this approach is on the right track.
do like this
Sub test()
Dim Data As Worksheet, ToWs As Worksheet
Dim vData, vDB, vArray
Dim i As Integer, j As Long, n As Long
Dim rngDB(1 To 4) As Range
Set Data = Sheets(1)
Set ToWs = Sheets(2)
vData = Data.Range("a1").CurrentRegion
vArray = Array("A", "B", "C", "D")
With ToWs
Set rngDB(1) = .Range("a4:b10")
Set rngDB(2) = .Range("d2:e5")
Set rngDB(3) = .Range("d7:e10")
Set rngDB(4) = .Range("g2:h10")
End With
For i = 1 To 4
n = 0
rngDB(i).Clear
vDB = rngDB(i)
For j = 1 To UBound(vData)
If vData(j, 1) Like vArray(i - 1) & "*" Then
n = n + 1
vDB(n, 1) = vData(j, 1)
vDB(n, 2) = vData(j, 2)
End If
Next j
rngDB(i) = vDB
Next i
End Sub
=COUNTIF($A:$A, "AXX")
will give you the count you seem to want. You can refine the range, and you can insert the reference to a cell instead of the hard "AXX". If you wish to use VBA you can call the function as Application.Countif(Range, CountWhat) where "Range" is a range you define in VBA and "CountWhat" is a variant.
I have a table that looks like this:
| A | B | C | D |
+-------+------------+------------+------------+
1 | Name | Language 1 | Language 2 | Language 3 |
+=======+============+============+============+
2 | John | English | Chinese | Spanish |
3 | Wendy | Chinese | French | English |
4 | Peter | Spanish | Chinese | English |
And I want to generate a table that has only one language column. The other two language columns should become new rows like this:
| A | B |
+-------+----------+
1 | Name | Language |
+=======+==========+
2 | John | English |
3 | John | Chinese |
4 | John | Spanish |
5 | Wendy | Chinese |
6 | Wendy | French |
7 | Wendy | English |
8 | Peter | Spanish |
9 | Peter | Chinese |
10 | Peter | English |
I understand this will probably will need a macro or something. If anybody point me in the right direction it would me much appreciate. I am not very familiar with VBA or the Excel object model.
This will do the trick. It is also dynamic supports as many language columns as you want with as many languages per person.
Assumes the data is formatted as per the example:
Sub ShrinkTable()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Column"
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
'Name
.Cells(writeRow, 1).Value = data(row, 1)
'Language
.Cells(writeRow, 2).Value = data(row, col)
writeRow = writeRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
Messy but should work:
For Each namething In Range("A1", Range("A1").End(xlDown))
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 2)
Range("A1").End(xlDown).Offset(1, 0) = namething.Value
Range("A1").End(xlDown).Offset(0, 1) = namething.Offset(0, 3)
namething.Offset(0, 2) = ""
namething.Offset(0, 3) = ""
Next
Then just sort
The following formula should work. The data in sheet2 would always reflect the data on sheet1 so you wouldn't have to re-run a macro to create a new list.
That being said, using a macro to generate it is probably a better choice as it would allow more flexability should you need to add a 4th language or something at a later date.
In Sheet2!A2
=INDIRECT("Sheet1!A"&ABS(INT((ROW()+1)/3))+1)
In Sheet2!B2
=INDIRECT("Sheet1!"&IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=0,"B",IF(ABS(INT((ROW()+1)/3)-(ROW()+1)/3)=(1/3),"C","D"))&ABS(INT((ROW()+1)/3))+1)
Add the column titles in A1 and B1 then autofill the formula down the sheet.
I have a sheet in Excel, Something like:
| Value1 | Data1 | Data1b | 1,3,4,8 |
| Value2 | Data2 | Data2b | 2 |
| Value3 | Data3 | Data3b | 6,7,8 |
I'd like to take that sheet and make another that divides up that final column into separate rows and keeps the other data in sync. So when the first sheet is updated, the second is also updated. And if a number is added to that final column in the first sheet, a new row is added to the second sheet.
The second sheet should look like this:
| Value1 | Data1 | Data1b | 1 |
| Value2 | Data2 | Data2b | 2 |
| Value1 | Data1 | Data1b | 3 |
| Value1 | Data1 | Data1b | 4 |
| Value3 | Data3 | Data3b | 6 |
| Value3 | Data3 | Data3b | 7 |
| Value1 | Data1 | Data1b | 8 |
| Value3 | Data3 | Data3b | 8 |
UPDATE: Below is the code I'm attempting to use. First of all, is what I have the best way? And is clearing then repopulating the right way to go about updating the second sheet? Finally, how do I make this automatically run when one updates the first sheet?
UPDATE: The only thing still not working is the sort at the end, does anyone have any idea why?
Private FROM_SHEET As String
Private TO_SHEET As String
Private START_ROW As Long
Private NUM_COL As Long
Sub oneToMany()
FROM_SHEET = "Sheet1"
TO_SHEET = "Sheet2"
START_ROW = 2
NUM_COL = 4
Dim fromSheet As Worksheet
Dim toSheet As Worksheet
Dim newRow As Long
Set fromSheet = Sheets(FROM_SHEET)
Set toSheet = Sheets(TO_SHEET)
toSheet.UsedRange.ClearContents
newRow = START_ROW
For i = START_ROW To fromSheet.Cells(fromSheet.Rows.Count, 1).End(xlUp).Row
Dim col As String
Dim nums() As String
col = fromSheet.Cells(i, NUM_COL)
nums = Split(col, ",")
For Each num In nums
fromSheet.Rows(i).Copy toSheet.Rows(newRow)
toSheet.Cells(newRow, NUM_COL) = Trim(num) 'Should copy then overwrite?
newRow = newRow + 1
Next num
Next
'Sort not working
toSheet.Range(toSheet.Cells(START_ROW, START_COL), toSheet.Cells(lastRow, lastCol)).Sort _
key1:=toSheet.Range(toSheet.Cells(START_ROW, NUM_COL), toSheet.Cells(lastRow, NUM_COL)), _
order1:=xlAscending, Header:=xlNo
End Sub
In answer to your first question if this is the only bit of data on the sheet then your clearcontents method is fine.
To automatically run look at the Worksheet_Change event on Sheet1. You can target the changes based on the cell changed....
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row < 4 And Target.Column < 5 Then
Call oneToMany
End If
End Sub
I have an Excel spreadsheet that looks something like this:
| | Job1 | Job2 | Job3 | Job4 | Job5 |
| Job1 | | | | | |
| Job2 | | | | | |
| Job3 | | | | | |
| Job4 | | | | | |
| Job5 | | | | | |
The cells between each row and column are different colors. I need to sort each column by the color orange and then copy the row names to a new sheet.
So in the end I would have a sheet like this:
| Job1 | Job2 |
| Job1 | Job4 |
| Job1 | Job5 |
| Job2 | Job3 |
| Job2 | Job5 |
The idea is if you can do Job1 you should have access to Job2. That is determined by the intersection between column and row from the first sheet. Try to have a sheet that shows the names instead of the colors. In all there are 83 jobs so manually doing this would have me copying over 4000.
Does anyone know how to create a macro to autofilter by color one column at a time and copy the contents of the row in column A1 to a new sheet?
I tried to make some sense of the actual data from your description and sample data/results. This is what I came up with.
With that as the active worksheet, I ran this macro.
Sub organize_by_color()
Dim rws As Long, c As Long, iCLR As Long, ws As Worksheet, wsT As Worksheet
Set ws = ActiveSheet
Set wsT = Worksheets.Add(after:=Sheets(Sheets.Count))
iCLR = 49407 'Orange e.g. RGB(255, 192, 0)
wsT.Cells(1, 1).Resize(1, 2) = Array("Job A", "Job B")
With ws.Cells(1, 1).CurrentRegion
.AutoFilter
For c = 2 To .Columns.Count
.AutoFilter Field:=c, Criteria1:=iCLR, Operator:=xlFilterCellColor
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
rws = Application.Subtotal(103, .Columns(1))
If CBool(rws) Then
.Columns(1).Copy Destination:=wsT.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
wsT.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(rws, 1) = ws.Cells(1, c).Value
End If
End With
.AutoFilter Field:=c
Next c
.AutoFilter
End With
Set ws = Nothing
Set wsT = Nothing
End Sub
This created a new worksheet at the end of the worksheet collection with the following results.
To my mind, there isn't much point in having columns E:F in the original data as any relationship noted there would already have been discovered in its reverse through the first three columns but I suppose that data redaction might account for the redundancy. Or I could be completely wrong in my assumptions as the data sample was not noted as to which cells in the matrix actually contained orange color backfill. Perhaps you will be able to transcribe this for your own purposes. Post back with questions and specifics if you run into difficulty.
I ended up making a web interface and converting everything over to a SQL database. So the SQL database and logic could do all this instead of trying to put excel on steroids.
I have a fairly large data-set that needs to be exported as CSV from Excel for import into another application. It can not have duplicate column headings but at this time there are many instances of that happening. I need to consolidate these headings and their respective data into single columns and remove duplicates.
I am trying to take data like this:
MAKE | MAKE | MAKE | MODEL | MODEL | TRIM |
-------------------------------------------
FORD | | | | | |
-------------------------------------------
| FIAT | | | | |
-------------------------------------------
| | MINI | | | |
-------------------------------------------
| | | PILOT | | |
-------------------------------------------
| | | | SC400 | |
-------------------------------------------
| | | | | EX |
-------------------------------------------
and turn it into this:
MAKE | MODEL | TRIM |
---------------------
FORD | | |
---------------------
FIAT | | |
---------------------
MINI | | |
---------------------
| PILOT | |
---------------------
| SC400 | |
---------------------
| | EX |
---------------------
Thanks in advance for any help in accomplishing this.
You need to separate the problem in smaller bits:
Read the unique titles and save them in a Dictionary object (as a value you might want to hold on the column they are going to be saved in)
You iterate through each cell getting the value and reading the column header.
You write that value in a new sheet on the column you are currently iterating through but for column position you look-up the current column title in the dictionary and get its position.
EDIT: Code tested and debugged. Works well.
Note: This method assumes that you have only 1 value per duplicated columns per row.
If you have more than 1 value for duplicated columns then the program will always save the last one (as it will overwrite the previous value). If you want a method that handles multiple values per column then you need to keep a Row number for each column in the new sheet and increment it by 1 each time you write data in that column.
Sub WriteValues()
'Aassuming your column titles are in row 1
Dim mainSheet As Worksheet
Set mainSheet = ActiveSheet
Dim maxCols As Integer
Dim maxRows As Double
maxRows = 0
maxCols = Cells(1, Columns.Count).End(xlToLeft).Column
Dim colPositions As Dictionary
Set colPositions = New Dictionary
'Iterate throgh row 1 to get all uniue values
Dim iCol As Integer
For iCol = 1 To maxCols
On Error Resume Next
colPositions.Add Cells(1, iCol).Value, colPositions.Count + 1
On Error GoTo 0
'Also record maxRows
If Cells(rows.Count, iCol).rows.End(xlUp).row > maxRows Then
maxRows = Cells(rows.Count, iCol).rows.End(xlUp).row
End If
Next i
Dim newSheet As Worksheet
Set newSheet = Sheets.Add
Dim col As Integer
Dim row As Double
'Write column titles in new sheet
Dim v As Variant
iCol = 1
For Each v In colPositions
Cells(1, iCol).Value = v
iCol = iCol + 1
Next v
'Main data iterator
For row = 2 To maxRows
For col = 1 To maxCols
Dim cellValue As String
Dim valueColumn As String
With mainSheet
cellValue = .Cells(row, col).Value
valueColumn = .Cells(1, col).Value
End With
If cellValue <> "" Then
newSheet.Cells(row, colPositions(valueColumn)).Value = cellValue
End If
Next col
Next row
End Sub