This is an Excel problem.
I have an Excel Rows with the following values:
cell value 1, 2, x, ,1=,2=, ,x=,2
cell address a1,b1,c1,d1,e1,f1,g1,h1,i1
I want to get all non-empty cell addresses from the above row.
i.e.
a1,b1,c1,e1,f1,h1,i1
Is it possible using vba/vbs to do the job?
thank you very much
You can use .SpecialCells(xlCellTypeConstants)
To demonstrate, run this, and observe result in the Imediate window
Sub demo()
Dim rng As Range, rNonEmpty As Range
Set rng = [A1:I1]
Set rNonEmpty = rng.SpecialCells(xlCellTypeConstants)
Debug.Print rNonEmpty.Address
End Sub
The following code will check an area of 10 rows by 1000 columns and finally will show the addresses of the non blank cells in cell A20:
Sub no_blank_cells()
Dim wks As Worksheet
Set wks = ActiveSheet
m = ""
maxrows = 10
maxcolumns = 1000
For i = 1 To maxrows
For j = 1 To maxcolumns
a = Cells(i, j)
If a <> "" Then
m = m & Cells(i, j).Address(RowAbsolute:=False, ColumnAbsolute:=False) & ", "
End If
Next j
Next i
msg = MsgBox(m, vbInformation)
wks.Cells(20, 1) = m
End Sub
If you want to change the area to be searched, modify the value of the variables maxrowsand maxcolumns.
Sub WriteNonNulValue()
'/*SELECT SHEET TO ANALIZE*/
Worksheets("Sheet1").Select
'/*SELECT ROW TO READ*/
Row_to_read = 1
'/*SELECT ROW IN WHICH WRITE*/
Row_to_write = 2
'/*NUMBER OF COLUMNS TO ANALIZE*/
Columns_to_analize = 11
'/*COUNTER WRITE*/
Columns_to_write = 1
For i = 1 To Columns_to_analize
If Trim(Cells(Row_to_read, i)) <> "" Then
'/*WRITE ADDRESS NO EMPTY CELLS*/
Cells(Row_to_write, Columns_to_write) = Cells(Row_to_read,i).Address
'/*INCREMENT COUNTER WRITE*/
Columns_to_write = Columns_to_write + 1
End If
Next i
End Sub
Related
Im trying to create a function which scans a column (job-trav-seq) and splits the values in each cell within a given range. It then compares these values to comparable cells in separate columns (so for instance job-trav-seq would have a cell 58546-05-10; this function would remove the dashes and compare the 58546 to job number, 05 to traveller ID and 07 to sequence No.
Basically, the function needs to first takes the A column (JobTravSeq) and breaks it apart into individual variables. (variable 1 should be compared with values in column B, values in variable 2 should be compared with column C and values in variable 3 should be compared with column D)
A loop should go up through the column cells as long as variable 1 = values in column B and variable 2 = values in column C (this is rowStart); this should be stored as a variable
A second loop should occur (rowEnd); which should loop down though the column cells as long as variable 1 = values in column B and variable 2 = values in column C; this should be stored as a variable
The code should then traverse between rowStart and rowEnd and check if variable 3 = values in column D, if it does then place an asterisk (or something similar) in front of the value to mark it as a current task
What im starting with: Sample Doc
What im trying to achieve: SampleDocOutput
any help would be most appreciated
heres my code for reference:
Sub SampleDocOrganise()
Dim i As Integer
Dim LastRow, rowCompare As Long
Dim variArr, rowStart, rowEnd, rangeID As Variant
Dim JobTravSeqRng As Range, jobNoRng As Range, TravellerRng As Range,
opSeqRng As Range, _
rng_JobTravSeq As Range, rng_JobNo As Range, rng_Traveller As Range,
rng_opSeq As Range
Set JobTravSeqRng = Range("A:A")
Set jobNoRng = Range("B:B")
Set TravellerRng = Range("C:C")
Set opSeqRng = Range("D:D")
For Each JobTravSeq In Selection
Str_Array = Split(JobTravSeq, "-")
For h = 0 To UBound(Str_Array)
Range("A:A").Find (Str_Array)
Range.Offset(, h + 1) = Str_Array(h)
For rowStart = 4 To Rows.Count
If Worksheets("Sheet1").Cells(Str_Array, 1).Value = jobNoRng.Value Then
If Cells(Str_Array, 2).Value = jobNoRng.Value Then
Cells.Value = rowStart
End If
End If
Next rowStart
For rowEnd = LastRow To 4 Step -1
If Cells(Str_Array, 1).Value = Range("B:B").Value Then
If Cells(Str_Array, 2).Value = Range("C:C").Value Then
Cells.Value = rowEnd
End If
End If
Next rowEnd
For rowCompare = rowStart To rowEnd
For Each opSeqArr In Str_Array
If Cells(Str_Array, 3).Value = Range("D:D").Value Then
If Cells(Str_Array, 1).Value = Range("B:B") Then
ActiveCell.Characters(0, 0).Insert (" P ")
With ActiveCell.Characters(0, Len(" P ")).Font
.Name = "OpSeq_Equals"
.Bold = True
.Color = -16776961
End With
MsgBox cell.Value = "*" & ""
' if cell changes then go to next loop
Else
' if cell changes then go to next loop
End If
End If
Next
Next
Next h
Next
End Sub
Sub MsgboxTasks() 'should display all rows that contain an asterisk in opSeq (current tasks)
End Sub
On tab1 I have a pivot table . When I double click subtotal number 256 on that pivot table, a new worksheet pops up with the details. Everything is just as expected.
On tab2, I have a formula in the field A1 . This formula refers to the subtotal value in the pivot (from tab1)
=GETPIVOTDATA("theId",tab1!$A$1)
A1 shows 256 . . . exactly as in the pivot table .
I need to be able to doulble click this A1 field and see a pop up worksheet with the details (as if I was clicking the pivot table)
The problem is GETPIVOTDATA returns a value only and no link or indirect reference
How can I do this ?
Sorry for the delay, but the weekend was in the middle.
Well here is my answer to how to show the data from a pivot, just with doble click inside a cell, in another sheet that have, the GETPIVOTDATA formula.
Note that in my pivot, I set to "Repeat all items labels" and use a old style pivot.
See the pictures:
For repeat all items labels
and the old style works better for me, and most of all, the macro (VBA)
That been said, let's code!!
All this inside a regular module.
Sub getDataFromFormula(theFormulaSht As Worksheet, formulaCell As Range)
Dim f
Dim arrayF
Dim i
Dim L
Dim iC
Dim newArrayF() As Variant
' Dim rowLables_Sort()
' Dim rowLables_Sort_i()
Dim T As Worksheet
Dim rowRange_Labels As Range
Dim shtPivot As Worksheet
Dim shtPivotName
Dim thePivot As PivotTable
Dim numRows
Dim numCols
Dim colRowRange As Range
Dim colRowSubRange As Range
Dim First As Boolean
Dim nR
Dim nC
Dim myCol
Dim myRow
Dim theRNG As Range
Set T = theFormulaSht 'the sheet where the formula is
'#####################################
'my example formula
'=GETPIVOTDATA("EURO",P!$A$3,"Descripcion","Ingresos Netos de Terceros ,","Mes","July","CuentaCrest","310100","Descripción Crest","Net revenue third parties","Producto","AFR","SubProducto","AFRI","TM1","Net Revenue")
'#####################################
T.Activate 'go!
f = formulaCell.Formula 'get the formula
f = Replace(f, "=GETPIVOTDATA", "") 'delete some things...
f = Replace(f, Chr(34), "")
f = Replace(f, ",,", ",") 'in my data, there is ,, and I need to fix this...
f = Right(f, Len(f) - 1) 'take the formual without parentesis.
f = Left(f, Len(f) - 1)
'####################################
'Restult inside "f"
'EURO,P!$A$3,Descripcion,Ingresos Netos de Terceros ,Mes,July,CuentaCrest,310100,Descripción Crest,Net revenue third parties,Producto,AFR,SubProducto,AFRI,TM1,Net Revenue
'####################################
arrayF = Split(f, ",")
'####################################
'Restult inside arrayF
'EURO,P!$A$3,Descripcion,Ingresos Netos de Terceros ,Mes,July,CuentaCrest,310100,Descripción Crest,Net revenue third parties,Producto,AFR,SubProducto,AFRI,TM1,Net Revenue
'####################################
shtPivotName = arrayF(1) 'set (just) the name of the sheet with the pivot
shtPivotName = Left(shtPivotName, InStr(1, shtPivotName, "!") - 1)
Set shtPivot = Sheets(shtPivotName) 'set the var with the sheet that contents the pivot
Set thePivot = shtPivot.PivotTables(1) 'store the pivot inside
If shtPivot.Visible = False Then 'if the sheet with the pivot is hidden... set visible.
shtPivot.Visible = xlSheetVisible
End If
shtPivot.Activate 'go there!
numRows = thePivot.RowRange.Rows.Count - 1 'the number of rows of the row Range
numCols = thePivot.RowRange.Columns.Count 'here the columns of the same range
Set rowRange_Labels = thePivot.RowRange.Resize(1, numCols)
'with Resize get jus the labels above the RowRange (see the picture (1))
iC = -1
First = True
For Each i In rowRange_Labels 'run the labels
iC = -1 'set the counter
If First Then 'check the flag to see if is the firt time...
First = False 'set the flag to FALSE to go the other part of the IF next time
Set colRowRange = Range(Cells(i.Row, i.Column), Cells(i.Row + numRows - 1, i.Column))
Do
iC = iC + 1 'just to set the counter
Loop While arrayF(iC) <> i.Value 'stop when gets equals and keep the counter
'in the array the values are just strings,
'but we know that is key-value pairs thats why adding +1 to iC we get the real info
'below the label
nR = colRowRange.Find(arrayF(iC + 1)).Row 'just used here
nC = WorksheetFunction.CountIf(colRowRange, arrayF(iC + 1)) + nR - 1 'here we count to set the range
Set colRowSubRange = Range(Cells(nR, i.Column), Cells(nC, i.Column)) 'set the range
myRow = colRowSubRange.Row 'here we get the row of the value
Else
Do 'this is simpler
iC = iC + 1
Loop While arrayF(iC) <> i.Value 'againg...
nR = colRowSubRange.Offset(, 1).Find(arrayF(iC + 1)).Row 'use the SubRange to get others subranges
nC = WorksheetFunction.CountIf(colRowSubRange.Offset(, 1), arrayF(iC + 1)) + nR - 1
Set colRowSubRange = Range(Cells(nR, i.Column), Cells(nC, i.Column))
myRow = colRowSubRange.Row 'idem
End If
Next i
numCols = thePivot.DataBodyRange.Columns.Count 'other part of the pivot... (see the picture (2))
Set theRNG = thePivot.DataBodyRange.Resize(1, numCols) 'just take the above labels
Set theRNG = theRNG.Offset(-1, 0)
iC = -1
For Each L In thePivot.ColumnFields 'for every label...
Do
iC = iC + 1
Loop While L <> arrayF(iC) 'idem
myCol = theRNG.Find(arrayF(iC + 1), , , xlWhole).Column
'always will be just one column...
Next L
Cells(myRow, myCol).ShowDetail = True 'here is the magic!!! show all the data
End Sub
And inside the Worksheet code this:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Left(Target.Formula, 13) = "=GETPIVOTDATA" Then 'Check if there a formula GetPivotData
getDataFromFormula Sheets(Me.Name), Target
End If
End Sub
See this picture to understand what happends to the formula:
The formula is split it as you can see f, into arrayF.
I'm sure you will need to do some changes, but this is very functional and basic, and will be easy to findout what you need.
Also:
This part of code helps me a lot to understand what the pivot had. Using the same data and pivot, I ran the code:
Sub rangePivot()
Dim Pivot As PivotTable
Dim rng As Range
Dim P As Worksheet
Dim D As Worksheet
Dim S As Worksheet
Dim i
Set P = Sheets("P") 'the sheet with the pivot
Set D = Sheets("D") 'the sheet with the data
Set S = Sheets("S") 'the sheet with the cells with the formula
S.Activate 'go
Set Pivot = P.PivotTables("PivotTable1") 'store the pivot here...
For i = 1 To Pivot.RowFields.Count
Cells(i, 1).Value = Pivot.RowFields(i)
Next i
For i = 1 To Pivot.ColumnFields.Count
Cells(i, 2).Value = Pivot.ColumnFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 3).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 4).Value = Pivot.DataLabelRange.Address(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 4).Value = Pivot.DataLabelRange.Address(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataBodyRange.Count
Cells(i, 6).Value = Pivot.DataBodyRange.Address(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 7).Value = Pivot.DataLabelRange.Address(i)
Next i
Cells(1, 8).Value = Pivot.ColumnGrand
Cells(1, 9).Value = Pivot.RowRange.Address
Cells(1, 11).Value = Pivot.TableRange1.Address
Cells(1, 12).Value = Pivot.TableRange2.Address
End Sub
And, as usual, if you need som help & improvement contact me. Hope this help other too.
If you want to do VBA you could set up an event like here:
http://www.ozgrid.com/forum/showthread.php?t=49050
Once you have that set up you need to develop some code that determines where the subtotal cell is (because those are prone to change). Once you have that address you can use Range([subtotal]).ShowDetail = True
Good day, I would love to ask you a question.
I have two colls with numbers and I need to compare first coll (longer) with second coll (shorter) and if there is a match, hide the row where the match occurs.
I have this so far:
Sub RowHide()
Dim cell As Range
Dim CompareCells As Range
Set CompareCells = Range("I2:I18")
For Each cell In Range("A2:A200")
If cell.Value = CompareCells Then
cell.EntireRow.Hidden = True
End If
Next
End Sub
My problem is that I don't know how to set value of CompareCells to start comparing. I'll appreciate every advice.
You have to set 2 separate ranges and compare them. If you want every cell compared with the one on the same line (A1 with B1, A2 with B2, etc) then consider using:
for i = 1 to something
set cell1 = range("A" & i)
set cell2 = range("B" & i)
if cell1.value = cell2.value then
'Do this, and do that!
cell1.entirerow.hidden = true
end if
next i
try this:
Sub RowHide()
Dim Longer As Range
Dim i As Double
i = 2 'Initial row
For Each Longer In Range("A2:A200")
If Longer.Value = Cells(i,2).Value Then
Longer.EntireRow.Hidden = True
End If
i = i + 1
Next
End Sub
PS:
Cells(RowIndex, ColumnIndex).Value: returns the value of the Row And Column.
ColumnIndex => Column A = 1, Column B = 2, an so on...
I looked into both of yours ideas and converted them into one and I finally get it working.
Here is my final code:
Sub RowHide()
Dim i As Integer
Dim j As Integer
For i = 2 To 197
Set FirstRange = Range("A" & i)
For j = 2 To 18
If FirstRange.Value = Cells(j, 8).Value Then
FirstRange.EntireRow.Hidden = True
End If
Next j
Next i
End Sub
Only modification if someone wants to use it is that you have to change numbers in for cycles according to number of rows in columns.
Thanks to both of you for your advices.
I am using the OFFSET Function to create a dynamic chart for the table depicted in the image below. Basically on the click of the button labeled "Copy Mean VCD Values" the code copies values from another sheet to the current sheet. If it encounters any cells with "#DIV/0!" I have it set to put "N/A" instead. But in this case I don't get a dynamic chart. If in stead of N/A I do "" it creates a dynamic chart but adds junk values "1" to the first set on the graph. I only get the desired results if I manually delete all the rows containing "N/A" below the last row containing data (See image for details).
https://lh6.googleusercontent.com/-OfjK6dSRQE8/U2JkdadjedI/AAAAAAAAABk/d8WDLuuC7Lk/w1068-h803-no/Offset+error.PNG
This is the code I am using for the Command Button "Copy Mean VCD Values":
Private Sub CommandButton2_Click()
r = 7
'//j increments the column number
'//i increments the row number
'//r is used for taking values from alternate cells(sheet3 column K) rowwise
For j = 2 To 14
For i = 7 To 26
If ThisWorkbook.Sheets(3).Range("K" & r & "").Text = "#DIV/0!" Then
ThisWorkbook.Sheets(2).Cells(i, j).Value = "N/A"
Else
ThisWorkbook.Sheets(2).Cells(i, j).Value = ThisWorkbook.Sheets(3).Range("K" & r & "").Value
End If
r = r + 2
Next i
Next j
End Sub
If I add the following code it works but it deletes the entire rows before and after the table. See image : https://lh6.googleusercontent.com/-WiM8HN61zkM/U2Jz2J_JxjI/AAAAAAAAACw/z4i3hlakyAI/w1598-h442-no/offset+delete+row.PNG
Private Sub CommandButton2_Click()
r = 7
'//j increments the column number
'//i increments the row number
'//r is used for taking values from alternate cells(sheet3 column K) rowwise
For j = 2 To 14
For i = 7 To 26
If ThisWorkbook.Sheets(3).Range("K" & r & "").Text = "#DIV/0!" Then
ThisWorkbook.Sheets(2).Cells(i, j).Value = "N/A"
Else
ThisWorkbook.Sheets(2).Cells(i, j).Value = ThisWorkbook.Sheets(3).Range("K" & r & "").Value
End If
r = r + 2
Next i
Next j
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("B7:B26")
Do
Set c = SrchRng.Find("N/A", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Value = ""
Loop While Not c Is Nothing
End Sub
And this is OFFSET Function I am using for Column B in this case:
=OFFSET('Data Summary Template'!$B$7,0,0, COUNTA('Data Summary Template'!$B$7:$B$26),1)
I can't exactly replicate this problem you're having... I think the initial problem must have something to do with the warning regarding invalid references. You should look in to that and figure out the cause, which is probably the cause of "extra" data in your chart.
If deleting the N/A values appears to be working, try something. Instead of:
Set SrchRng = ActiveSheet.Range("B7:B26")
Do
Set c = SrchRng.Find("N/A", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Value = ""
Loop While Not c Is Nothing
Do this:
Dim tblCell as Range
Dim tbl as ListObject
Set tbl = ActiveSheet.ListObjects(1)
For each tblCell in tbl.DataBodyRange.Columns(2).Cells
If tblCell.Value = "N/A" Then
tblCell.Resize(1, tbl.DataBodyRange.Columns.Count - 1).Value = vbNullString
End If
Next
Hello, I am doing a macro that copy the values on the columns, VALUES1, VALUES2, VALUES3 if it is not blank when the ARTICLE is the same.
I would have the first spreadsheet and I want the macro to return the second Spreadsheet.
I have managed how to make it:
Sub test()
Dim i, last, j, x As Integer
Dim R As Range
last = Sheets("List2").Range("A100000").End(xlUp).Row - 2
For i = 0 To last
Set R = Sheets("List2").Range("A2")
If Not WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value) = 0 Then
For j = 1 To WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
Sheets("List2").Range("A2").Offset(i, 0).Value)
Set R = Sheets("List2").Columns(1).Find(Sheets("List2").Range("A2"). _
Offset(i, 0).Value, R, LookAt:=xlWhole)
For x = 0 To 2
If Not Sheets("List2").Range("B2").Offset(i, x).Value = "" Then
R.Offset(0, "1" + x).Value = Sheets("List2"). _
Range("B2").Offset(i, x).Value
End If
Next x
Next j
End If
Next i
End Sub
but the problem it takes too long, 'cause I have around 10.000 Rows and 20 Columns, and besides the Spreadsheet is not in order, so it could be to has a disorder, something like (A, B, B, A, ...)
Is there any way to make it faster o better???
Thanks a lot. Themolestones.
Here is a very easy solution with formulas to your problem:
Sheet2!A1=Sheet1!A1
Sheet2!B1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!B:B)
Sheet2!C1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!C:C)
Sheet2!D1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!D:D)
Put these formulas in the cells left of the = and copy down. You really need only the first two, because you can copy the second also to the right.
You need Sheet1 to be sorted by article.
That's it.
Of course, there might be occasions, when it is just necessary to implement this with VBA. Usually the fastest way to handle large amounts of cells with VBA, is to use array-copies of your ranges. Using worksheet-functions and looping through single cell references slows you down heavily.
Edit:
This would be my VBA solution
Public Sub Demo()
Dim arrRange() As Variant
Dim arrRangeResult() As Variant
Dim i As Long
Dim j As Long
Dim copyVal As Variant
Dim copyCond As Variant
Dim copyCol As Long
'create two copies of the origin data
arrRange = Range("A:D")
arrRangeResult = Range("A:D")
'loop through first data-copy, downwards through the articles
For i = LBound(arrRange, 1) + 1 To UBound(arrRange, 1)
'stop loop, if no article was found
If arrRange(i, 1) = "" Then Exit For
'store current article ID
copyCond = arrRange(i, 1)
'loop sideways through value-columns
For j = LBound(arrRange, 2) + 1 To UBound(arrRange, 2)
'store value & column, when found
If arrRange(i, j) <> "" Then
copyVal = arrRange(i, j)
copyCol = j
Exit For
End If
Next j
'loop through output array and paste value
For j = LBound(arrRangeResult, 1) + 1 To UBound(arrRangeResult, 1)
If arrRangeResult(j, 1) = copyCond Then
'paste-down found value to all occurences of article
arrRangeResult(j, copyCol) = copyVal
ElseIf arrRangeResult(j, 1) = "" Then
'early stop, when no article ID is found
Exit For
End If
Next j
Next i
'create output
Range("K:N") = arrRangeResult
End Sub