How using VBScript I can count the number of rows filled with data and how many column has a value for a particular row?
Col1 Col2 Col3 ........ColN-1 ColN+1...ColN+2.......ColN+2
Row1 A B Null Null
Row2 1 2 Y .
Row3 2 .
Row4 P Z
. .
.
.
RowN-2 .
RowN-1 T L Null.......Null
RowN S
RowN+1 Null ........(till the last column of the excel sheet that its version supprts.)
So here my required Loop iteration which i would use for my other logic is N for rows and for columns it would be N+1
Update
Option Explicit
Dim rg,CountBlank
For C=0 to 10
Set rg = Ob6.Range(Ob6.Columns(c),Ob6.Columns(c))
CountBlank = objExcel1.Application.WorksheetFunction.CountBlank(rg)
MsgBox("Column"&C": "&"Has"&(rg.rows.Count-CountBlank))
Next
Thanks
Try this to get you started. It will show for each row the number of columns that have data, and for each column the number of rows that have data. You can then modify it to more suit your needs:
EDIT: Code updated to capture first row / column with only 1 column / row of data:
Option Explicit
Dim rg
'loop through columns
For C=0 to 10
Set rg = Ob6.Columns(c)
If objExcel1.Application.WorksheetFunction.CountA(rg) =1 Then
Exit For
End If
Next
MsgBox("Column" & C & " is first column with only 1 row")
'loop through rows
For C=0 to 10
Set rg = Ob6.Rows(c)
If objExcel1.Application.WorksheetFunction.CountA(rg) =1 Then
Exit For
End If
Next
MsgBox("Column" & C & " is first row with only 1 column")
Related
I have a huge Excel sheet with about 2000 rows.
So Row 1 is the first header, the columns are: Unique Name, Length, Elevation. Then there is a bunch of data related to these columns.
Row 8 is another header, the columns are: Unique Name, Elevation, Element type. Again some data follows these columns.
And so on goes the Excel sheet with many such rows which are headers.
These headers are not in same order. Here is an example of Excel Sheet1:
Unique Name Length (ft) Elevation (ft) this is Row 1 (header1)
A 20 4 this is Row 2
B 5 10 this is Row 3
C 10 3
D 11 40
E 3 60
Row 7 is blank
Unique Name Elevation (ft) Element Type this is Row 8 (header2)
1 20 Pipe
2 5 Pipe
3 10 Pipe
Row 12 is blank
Unique Name Element Type Elevation Status this is Row 13 (header 3)
A1 VALVE 10 Open
A2 VALVE 2 Open
A3 VALVE 100 Open
. . . .
. . . .
. . . .
. . . .
I need to copy every single columns data from Sheet1 based on specific headers and paste it to Sheet2.
Here is an example of Sheet2, this is what I need:
Unique Name Length (ft) Elevation (ft) Status Element Type this is the only header I need
A 20 4
B 5 10
C 10 3
D 11 40
E 3 60
1 20 Pipe
2 5 Pipe
3 10 Pipe
A1 10 Open VALVE
A2 2 Open VALVE
A3 100 Open VALVE
. . . . .
. . . . .
. . . . .
. . . . .
I have searched a lot, and Alex's VBA code below is the closest I found in this help forum. But it obviously works only for data belonging to Row 1 Header.
Sub CopyPasteData()
Dim header As Range, headers As Range
Set headers = Worksheets("Sheet1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("Sheet2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)),
Application.Match(header, headers, 0), 0)
End Function
Thank you.
Should be easy enough to do if you can key off of the "Unique Name" in the first column as an indicator that a new header has been reached. You basically just need to keep track of 3 different mappings - columns for headings that have already been located, rows for unique names that have already been located, and the positions of the headers in the current section.
Dictionaries from the Microsoft Scripting Runtime work well for this. Something like this should do the trick:
Private Sub MergeSections()
Dim source As Worksheet, target As Worksheet
Dim found As Dictionary, current As Dictionary, uniques As Dictionary
Set source = ActiveSheet
Set target = ActiveWorkbook.Worksheets("Sheet2")
Set found = New Dictionary
Set uniques = New Dictionary
Dim row As Long, col As Long, targetRow As Long, targetCol As Long
targetRow = 2
targetCol = 2
Dim activeVal As Variant
For row = 1 To source.UsedRange.Rows.Count
'Is the row a header row?
If source.Cells(row, 1).Value2 = "Unique Name" Then
'Reset the current column mapping.
Set current = New Dictionary
For col = 2 To source.UsedRange.Columns.Count
activeVal = source.Cells(row, col).Value2
If activeVal <> vbNullString Then
current.Add col, activeVal
'Do you already have a column mapped for it?
If Not found.Exists(activeVal) Then
found.Add activeVal, targetCol
targetCol = targetCol + 1
End If
End If
Next col
Else
activeVal = source.Cells(row, 1).Value2
'New unique name?
If Not uniques.Exists(activeVal) Then
'Assign a row in the target sheet.
uniques.Add activeVal, targetRow
target.Cells(targetRow, 1).Value2 = activeVal
targetRow = targetRow + 1
End If
For col = 2 To source.UsedRange.Columns.Count
'Copy values.
activeVal = source.Cells(row, col).Value2
If source.Cells(row, col).Value2 <> vbNullString Then
target.Cells(uniques(source.Cells(row, 1).Value2), _
found(current(col))).Value2 = activeVal
End If
Next col
End If
Next row
'Write headers to the target sheet.
target.Cells(1, 1).Value2 = "Unique Name"
For Each activeVal In found.Keys
target.Cells(1, found(activeVal)).Value2 = activeVal
Next activeVal
End Sub
have currently browsed the forums and have came up with a code to compare two columns from two separate excel books and then highlight anything matching with the CompareRange. Here is a few more details about the problem:
I have two excel sheets. And data like this in each sheet:
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•6 .6 8 .45
•5 .5 9 .55
•4 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
As you can see, given this example nothing should be highlighted once the macro is run since nothing from Column A or B from the first sheet matches directly with Column N & O from the second sheet. The problem is that with the macro (module) I have come up with will highlight "3" from Column A and ".2" from Column B, just because they appear in Column N & Column O respectivally.
What I want: I only want a number to be highlighted if both the numbers "7" & ".7" are matched in the same row of Column N & Column O on the other spreadsheet. I have no idea how to do this. To be a little more precise, I'll give an example. Say I edited the data to be like this.
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•8 .45 8 .45
•5 .5 9 .55
•11 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
With this data, I would want the second row of A & B ("8" & ".45") highlighted, while my error "3" of Column A and ".2" of Column B is not highlighted. Also, I would like it if row 4 of Column A & B ("11" & ".4") is not highlighted at all either, just because in O it is .2 and in B it would be .4 even though the 11's match.
Please advise. Thanks in advance.
Attached is the macro/module I have entered in which is working kind of correctly but producing the mistake.
And also, (kind of a lesser problem), both the files with data will have the same header, example would be if Column A & Column N both had "Dogs" as it's title in Row 1 and Column B & O both had "Cats" as it's title in Row 1. Is there anyway the macro can be adjusted so it compares those two columns between the two workbooks without me even having to select or assigning a range? Thank you so much.
Sub Find_Matches()
Dim Column1 As Range
Dim Column2 As Range
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
If Column1.Columns.Count > 1 Then
Do Until Column1.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
Loop
End If
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
If Column2.Columns.Count > 1 Then
Do Until Column2.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column2.Rows.Count <> Column1.Rows.Count Then
Do Until Column2.Rows.Count = Column1.Rows.Count
MsgBox "The second column must be the same size as the first"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column1.Rows.Count = 65536 Then
Set Column1 = Range(Column1.Cells(1), Column1.Cells(ActiveSheet.UsedRange.Rows.Count))
Set Column2 = Range(Column2.Cells(1), Column2.Cells(ActiveSheet.UsedRange.Rows.Count))
End If
Dim CompareRange As Variant, x As Variant, y As Variant
' Set CompareRange equal to the range to which you will
' compare the selection.
Set CompareRange = Workbooks("Book4").Worksheets("Sheet1").Range("N2:N7")
Set CompareRange1 = Workbooks("Book4").Worksheets("Sheet1").Range("O2:O7")
' NOTE: If the compare range is located on another workbook
' or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2"). _
' Worksheets("Sheet2").Range("C1:C5")
'
' Loop through each cell in the selection and compare it to
' each cell in CompareRange.
For Each x In Column1
For Each y In CompareRange
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
For Each x In Column2
For Each y In CompareRange1
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
End Sub
Replace both of your loops with one that compares both pairs of cells at the same time:
For i = 1 To Column1.Rows.Count
For j = 1 To compareRange.Rows.Count
If Column1.Cells(i, 1) = compareRange.Cells(j, 1) Then
If Column2.Cells(i, 1) = compareRange1.Cells(j, 1) Then
Column1.Cells(i, 1).Interior.Color = vbYellow
Column2.Cells(i, 1).Interior.Color = vbYellow
End If
End If
Next j
Next i
I am wondering for an VBscript by which i can move the empty row values in one side and the non-empty values in the other side Keeping the data description intact.This can be done using Looping technique. But i want some faster process if any can be implemented using VBscript.
Input Sheet
Code Error-I Error-II Error-III
Type-1 Type-2 Type-3 Test-A Test-B Test-C Prog-A Prog-B Prog-C
Code-A Yes No Yes X Z
Code-B No Yes Yes Y Z
Code-C Yes Yes No Z
Output Sheet
Code Error-I Error-II Error-III
Type-1 Type-2 Test-A Test-B Prog-A Prog-B
Code-A Yes No Yes X Z
Code-B No Yes Yes Y Z
Code-C Yes Yes No Z
Update : After shifting if it is found that a column in a group contains not a single data,that column should need to be dropped form the sheet.
I wrote the below code for all sets of columns but it is producing incorrect data shifts. Can you say where i was wrong?
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1
Dim row,col1,col2
Dim TotlColumnSet : TotlColumnSet =3
Dim AssColmuns : AssColmuns=3
Dim EachColumnSet, ColStart, ColEnd
Set objExcel1 = CreateObject("Excel.Application")
strPathExcel1 = "D:\VA\Copy of Test.xlsx"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
ColStart = 2
For EachColumnSet = 1 To TotlColumnSet
For row = 3 To 5
' find the first empty cell in the row
col1 = ColStart'2
ColEnd = ColStart + AssColmuns
Do Until IsEmpty(objSheet1.Cells(row, col1)) Or col1 > ColEnd-1'4
col1 = col1 + 1
Loop
' collapse right-hand cells to the left
If col1 < ColEnd-1 Then '4
' proceed only if first empty cell is left of the right-most cell
' (otherwise there's nothing to do)
col2 = col1 + 1
Do Until col2 > ColEnd-1'4
' move content of a non-empty cell to the left-most empty cell, then
' increment the index of the left-most empty cell (the cell right of
' the former left-most empty cell is now guaranteed to be empty)
If Not IsEmpty(objSheet1.Cells(row, col2).Value) Then
objSheet1.Cells(row, col1).Value = objSheet1.Cells(row, col2).Value
objSheet1.Cells(row, col2).Value = Empty
col1 = col1 + 1
End If
col2 = col2 + 1
Loop
End If
Next
ColStart = ColEnd
Next
'=======================
objExcel1.ActiveWorkbook.SaveAs strPathExcel1
objExcel1.Workbooks.close
objExcel1.Application.Quit
'======================
Update:
By Mistake i didn't show in the output table columns Type-3,Test-C,Prog-C. But they should need to be present there.
If I understand you correctly, you want to collapse each column set to the left. If so, the column titles in the result are indeed misleading.
Does the sheet always have 3 rows with 3 sets of 3 columns each? In that case you could simply use the absolute positions of the cells. Example for the first set of columns:
filename = "..."
Set xl = CreateObject("Excel.Application")
xl.Visible = True
Set wb = xl.Workbooks.Open(filename)
Set ws = wb.Sheets(1)
For row = 3 To 5
' find the first empty cell in the row
col1 = 2
Do Until IsEmpty(ws.Cells(row, col1)) Or col1 > 4
col1 = col1 + 1
Loop
' collapse right-hand cells to the left
If col1 < 4 Then
' proceed only if first empty cell is left of the right-most cell (otherwise
' there's nothing to do)
col2 = col1 + 1
Do Until col2 > 4
' move content of a non-empty cell to the left-most empty cell, then
' increment the index of the left-most empty cell (the cell right of the
' former left-most empty cell is now guaranteed to be empty)
If Not IsEmpty(ws.Cells(row, col2).Value) Then
ws.Cells(row, col1).Value = ws.Cells(row, col2).Value
ws.Cells(row, col2).Value = Empty
col1 = col1 + 1
End If
col2 = col2 + 1
Loop
End If
Next
I have data in (Sheet4) columns A to I:
I'm trying to compare data for all rows (Only on column A and B) to see if any of the rows is duplicated, if it is: excel should highlight both rows.
Example:
A B C......I
s 1 x
s 3 w
e 5 q
s 1 o
Row 1 and 4 should be highlighted as values are the same for column A and B.
I shouldn't modify the sheet (no modification to the columns or rows should be done to the sheet), and the number of rows is not always known (not the same for all files).
Is there an easy way (using macros) to do this???
This is an attempt I have tried, but it is increasing my file to 7MB!!!!! I'm sure there should be an easier way to compare rows for an unknown number of rows and just highlight the dupllicates if they exist:
Public Sub duplicate()
Dim errorsCount As Integer
Dim lastrow As Integer
Dim lastrow10 As Integer
errorsCount = 0
lastrow = Sheet4.Cells(Rows.Count, "A").End(xlUp).Row 'is the row number of the last non-blank cell in the specified column
lastrow10 = lastrow
Sheet10.Range("B1:B" & lastrow10).Value = Sheet4.Range("A1:A" & lastrow).Value
Set compareRange = Sheet10.Range(column + "2:" & Sheet10.Range(column + "2").End(xlDown).Address)
For Each a In Sheet10.Range(column + "2:" & Sheet10.Range(column + "2").End(xlDown).Address)
c = a.Value
If c <> Null Or c <> "" Then
If name = "testing" Then
If WorksheetFunction.CountIf(compareRange, c) > 1 Then
a.Interior.ColorIndex = 3
errorsCount = errorsCount + 1
End If
End If
End If
Next a
If errorsCount > 0 Then
MsgBox "Found " + CStr(errorsCount) + " errors"
Else
MsgBox " No errors found."
End If
End Sub
Silly answer to you.
J1 or just duplicate sheet.
J1 =CONCATENATE(A1,"#",B1) > drag down > J:J > conditional format > highlight cells rules > duplicate values.
(* replace the # to any string which you think not possible in the original A:A and B:B.)
I do this all the time.
To collect all duplicates just SORT with color.
I have a large set of Excel rows and i have empty row in between .
So i wanna count that empty rows as groups .
put every group count above row then delete all empty rows .
ex.
data row .
data row . i wanna count all empty row below.put on cell on that row (3)
empty .
empty .
empty .
data row.
data row.
data row.
data row . (2).
empty row.
empty row .
data row . (4)
empty.
empty.
empty.
empty.
.
.
.
.
etc
Suppose you have your data in column A of your spreadsheet (starting in cell A1) and you would like to count the empty spaces and delete the rows as follows:
Col A Col B Col A Col B
1 AAA AAA 2
2 BBB 1
3 CCC 0
4 BBB DDD 2
5 ---- Output ---> EEE
6 CCC
7 DDD
8
9
10 EEE
The following code will achieve that outcome:
Sub CountEmptyRows()
Dim lastRow As Long, rw As Long, count As Integer
lastRow = Range("A65536").End(xlUp).Row - 1
count = 0
For rw = lastRow To 1 Step -1
If IsEmpty(Cells(rw, 1)) Then //If cell is empty increment the count and delete the row
count = count + 1
Cells(rw, 1).EntireRow.Delete
Else
Cells(rw, 2) = count //Display emtpy row count and then reset counter
count = 0
End If
Next rw
End Sub