I using Labview to generate a Excel report that essentially pastes an array into the spreadsheet. There are gaps in the spreadsheet, for example:
1
2
3
1
2
3
But because I am inserting an array into the spreadsheet, the gaps are empty, but they aren't blank.
When I run vba code checking each cell using "IsEmpty," it returns true. But if I run an excel formula using "ISBLANK," it returns false. I have tried the following, but it doesn't make the cell blank.
If IsEmpty(Cells(r,c)) Then
Cells(r,c).Value = ""
Cells(r,c).ClearContents
Cells(r,c) = ""
I want to make the cells blank without having to delete them. This is because I'm trying to use .End in my VBA code, but it doesn't stop at the gaps.
You don't need to check IsEmpty(), instead:
If Cells(r, c).Value = "" Then Cells.ClearContents
This will remove Nulls. By Nulls, I mean zero-length Strings.
This might be overkill, but it'll work for you:
Sub tgr()
Dim ws As Worksheet
Dim rClear As Range
Dim aData As Variant
Dim lRowStart As Long
Dim lColStart As Long
Dim i As Long, j As Long
Set ws = ActiveWorkbook.ActiveSheet
With ws.UsedRange
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData = .Value
Else
aData = .Value
End If
lRowStart = .Row
lColStart = .Column
End With
For i = LBound(aData, 1) To UBound(aData, 1)
For j = LBound(aData, 2) To UBound(aData, 2)
If Len(Trim(aData(i, j))) = 0 Then
If rClear Is Nothing Then
Set rClear = ws.Cells(lRowStart + i - 1, lColStart + j - 1)
Else
Set rClear = Union(rClear, ws.Cells(lRowStart + i - 1, lColStart + j - 1))
End If
End If
Next j
Next i
If Not rClear Is Nothing Then rClear.ClearContents
End Sub
Related
I made a macro that calculates some formulas, that are stored as text at first in one column, by replacing some codes by their associated int values and later print the result in the desired column.
e.g. dAGR99001/dAGR99002 is replaced by 2/2 since their values for certain month/year are both 2, later this text formula converted into a proper formula by adding the equal sign at the beginning and prints the result of it in another column.
My problem is that when replacing the codes by their associated int values, Excel automatically converts it to a date. For example on the above formula, it should be replaced by 2/2 but instead, it's returning 2/Feb (2/Fev in Portuguese) as in 2/2/2019 and when later calculating it the final result is 43498 (days since 1/1/1900).
How can I prevent this from happening?
→
Note that both the column where the text formula is and the associated int values of the codes are stored has General format. I also tried to save them as Number or Text but the problem still persisted.
This is my code
Sub Looper()
Dim x As Integer
For x = 10 To 60
getformulas x
Next x
End Sub
Sub getformulas(MonthNum As Integer)
Dim wb As Workbook
Dim wsLookup As Worksheet
Dim wsData As Worksheet
Dim wsPaste As Worksheet
Dim aLookup() As Variant
Dim aData() As Variant
Dim lCodesLookupCol As Long
Dim lCodesConvertCol As Long
Dim i As Long
Dim lrow As Long
Call OptimizeCode_Begin
With Sheets("Variaveis")
lrow = .Range("A:BA").Find(What:="", after:=.Range("A2"), searchdirection:=xlPrevious).Row
End With
Set wb = ActiveWorkbook
Set wsData = wb.Worksheets("Indicadores")
Set wsLookup = wb.Worksheets("Variaveis")
Set wsPaste = wb.Worksheets("Formulas")
aLookup = wsLookup.Range("A2:BA" & lrow) '("A2:AO441")
lCodesLookupCol = LBound(aLookup, 2)
lCodesConvertCol = UBound(aLookup, 2)
With wsData.Range("H2", wsData.Cells(wsData.Rows.Count, "H").End(xlUp))
For i = 1 To UBound(aLookup, 1)
.Replace aLookup(i, lCodesLookupCol), aLookup(i, MonthNum - 4), xlPart, , False
Next i
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Formula
Else
aData = .Formula
End If
For i = 1 To UBound(aData, 1)
If Len(aData(i, 1)) > 0 And Left(aData(i, 1), 1) <> "=" Then aData(i, 1) = "=" & aData(i, 1)
wsData.Cells(i + 1, MonthNum) = aData(i, 1)
If Left(aData(i, 1), 1) <> "=" Then
wsData.Cells(i + 1, MonthNum).Value = "Error"
End If
On Error Resume Next
Next i
End If
Call OptimizeCode_End
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End With
Worksheets("Formulas").Range("B2:B228").Copy
Worksheets("Indicadores").Range("H2:H228").PasteSpecial Paste:=xlPasteFormulas
Application.Goto Worksheets("Indicadores").Cells(2, 6)
End Sub
I have a large table of lab measurement logs, which I work with using arrays.
(Im a chemist, a lab technician and Ive started to learn VBA only last week, please bear with me.)
Im trying to figure out, how to load the table into an array and then remove rows with an empty value in the 5th column so that I can "export" the table without blanks in the 5th column via an array into a different sheet.
I first tested this with some code I found for a 1D array, where I would make 2 arrays, one placeholder array which Id loop through adding only non-blanks to a second array.
For Counter = LBound(TestArr) To UBound(TestArr)
If TestArr(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
NoBlanksArr(UBound(NoBlanksArr)) = TestArr(Counter, 1)
ReDim Preserve NoBlanksArr(0 To UBound(NoBlanksArr) + 1)
End If
Next Counter
It works in 1D, but I cant seem to get it two work with 2 dimensions.
Heres the array Im using for reading and outputting the data
Sub ArrayTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim TestArray() As Variant
Dim Dimension1 As Long, Dimension2 As Long
Sheets("Tracker").Activate
Dimension1 = Range("A3", Range("A2").End(xlDown)).Cells.Count - 1
Dimension2 = Range("A2", Range("A2").End(xlToRight)).Cells.Count - 1
ReDim TestArray(0 To Dimension1, 0 To Dimension2)
'load into array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
TestArray(Dimension1, Dimension2) = Range("A4").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
Sheets("Output").Activate
ActiveSheet.Range("A2").Select
'read from array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
ActiveCell.Offset(Dimension1, Dimension2).Value = TestArray(Dimension1, Dimension2)
Next Dimension2
Next Dimension1
Erase TestArray
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thank you for any help in advance.
The Redim Preserve statement does not work for two-dimensional arrays if you want to change the number of records (rows).
You could load the range into an array, and then when you want to export the array to another range, loop through that array while skipping blank records.
An example:
Option Explicit
Sub ArrayTest()
Dim wb As Workbook, wsInput As Worksheet, wsOutput As Worksheet
Dim myArr As Variant
Dim i As Long, k As Long, LRow As Long
Set wb = ThisWorkbook
Set wsInput = wb.Sheets("Tracker")
Set wsOutput = wb.Sheets("Output")
LRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row + 1
'Load a range into the array (example range)
myArr = wsInput.Range("A1:Z100")
'Fill another range with the array
For i = LBound(myArr) To UBound(myArr)
'Check if the first field of the current record is empty
If Not Len(myArr(i, 1)) = 0 Then
'Loop through the record and fill the row
For k = LBound(myArr, 2) To UBound(myArr, 2)
wsOutput.Cells(LRow, k) = myArr(i, k)
Next k
LRow = LRow + 1
End If
Next i
End Sub
From your code, it appears you want to
test a column of data on a worksheet to see if there are blanks.
if there are blanks in the particular column, exclude that row
copy the data with the excluded rows to a new area
You can probably do that easier (and quicker) with a filter: code below checking for blanks in column2
Option Explicit
Sub removeCol2BlankRows()
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim rSrc As Range, rRes As Range
Set wsSrc = ThisWorkbook.Worksheets("sheet1")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion 'many ways to do this
Set wsRes = ThisWorkbook.Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 10)
If wsSrc.AutoFilterMode = True Then wsSrc.AutoFilterMode = False
rSrc.AutoFilter field:=2, Criteria1:="<>"
rSrc.SpecialCells(xlCellTypeVisible).Copy rRes
wsRes.AutoFilterMode = False
End Sub
If you really just want to filter the VBA arrays in code, I'd store the non-blank rows in a dictionary, and then write it back to the new array:
Option Explicit
Sub removeCol2BlankRows()
Dim testArr As Variant
Dim noBlanksArr As Variant
Dim myDict As Object
Dim I As Long, J As Long, V
Dim rwData(1 To 4) As Variant
With ThisWorkbook.Worksheets("sheet1")
testArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
Set myDict = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(testArr, 1)
If testArr(I, 2) <> "" Then
For J = 1 To UBound(testArr, 2)
rwData(J) = testArr(I, J)
Next J
myDict.Add Key:=I, Item:=rwData
End If
Next I
ReDim noBlanksArr(1 To myDict.Count, 1 To 4)
I = 0
For Each V In myDict.keys
I = I + 1
For J = 1 To 4
noBlanksArr(I, J) = myDict(V)(J)
Next J
Next V
End Sub
At a high level I am trying to set a cell equal to a random cell within a range. The issue I am having is that in this range I want to pull a random Value from, the Value I am taking is the result of an 'if' expression that either sets the cell to a Value or "". So when I chose the random value I only want to choose cells that have an actual value, not the "".
Does anyone know how to get this expected behavior?
The code below shows what I have tried currently, each large block is commented to help with understanding. The block I need help with replaces the values in each column until the next cell is blank then moves to the next column.
upperBound = 1798
lowerBound = 2
Randomize
'This loop section populates the data area with a static value in cell 9,3 then 9,4 etc..
For j = 3 To 15
val = Cells(9, j).Value
For i = 1 To val
Cells(12 + i, j).Value = Cells(9, j)
Next i
Next j
'This loop section uses the cells already populated down each column and replaces that value with the random value from the other range
Dim x As Integer
' Set numrows = number of rows of data.
For j = 3 To 15
NumRows = Range(Cells(13, j), Cells(13, j).End(xlDown)).Rows.Count
' Select cell 13,j.
Cells(13, j).Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
ActiveCell.Value = Worksheets("2017 Role IDs").Cells(Int((upperBound - lowerBound + 1) * Rnd + lowerBound), 2).Value
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Next j
This is the data before the second block runs. I want to replace the values that just match the number in the second row with the random number in the range:
This is what I would like to look like:
But currently it looks like this because the random selector is taking blank values:
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsNums As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim vData As Variant
Dim aNums() As Double
Dim aResults() As Variant
Dim lNumCount As Long
Dim lMaxRows As Long
Dim lRowCount As Long
Dim ixNum As Long
Dim ixResult As Long
Dim ixCol As Long
Set wb = ActiveWorkbook
Set wsNums = wb.Worksheets("2017 Role IDs")
Set wsDest = wb.ActiveSheet
With wsNums.Range("B2", wsNums.Cells(wsNums.Rows.Count, "B").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
lNumCount = WorksheetFunction.Count(.Cells)
If lNumCount = 0 Then Exit Sub 'No numbers
ReDim aNums(1 To lNumCount)
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
'Load populated numeric cells into the aNums array
For Each vData In aData
If Len(vData) > 0 And IsNumeric(vData) Then
ixNum = ixNum + 1
aNums(ixNum) = vData
End If
Next vData
End With
lMaxRows = Application.Max(wsDest.Range("C9:O9"))
If lMaxRows = 0 Then Exit Sub 'Row count not populated in row 9 for each column
ReDim aResults(1 To WorksheetFunction.Max(wsDest.Range("C9:O9")), 1 To 13)
'Populate each column accordingly and pull a random number from aNums
For ixCol = 1 To UBound(aResults, 2)
If IsNumeric(wsDest.Cells(9, ixCol + 2).Value) Then
For ixResult = 1 To CLng(wsDest.Cells(9, ixCol + 2).Value)
Randomize
aResults(ixResult, ixCol) = aNums(Int(Rnd() * lNumCount) + 1)
Next ixResult
End If
Next ixCol
wsDest.Range("C13").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
I have cells containing duplicate values that i want to merge quickly. The table looks like this:
Sub MergeCells()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant
ReDim arr(1 To 1) As Variant
With ThisWorkbook.Sheets("tst")
Set Rng = .Range("A2:D11")
lRow = Rng.End(xlDown).Row
For J = 1 To 4
For I = lRow To 2 Step -1 'last row to 2nd row
If Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I - 1, J))) Then
Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
arr(UBound(arr)) = R.Address
ReDim Preserve arr(1 To UBound(arr) + 1)
End If
Next I
Next J
ReDim Preserve arr(1 To UBound(arr) - 1)
Set R = .Range(Join(arr, ","))
'MsgBox R.Areas.Count
'R.Select
'R.MergeCells = True
With R
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Stop
End With
Application.DisplayAlerts = True
End Sub
The duplicate cells ranges could be disjointed or non-adjacent cells. I want a way to quickly identify such duplicate ranges and merge them without using a For loop. [Don't know, but think there could be a fastest innovative way without loops probably using some combination of Excel array formulae and VBA code, to select and merge duplicate cell ranges.]
BTW the above code works fine till it shoots up the following error at line .Merge.
EDIT
This is a snapshot of the Watch window showing the arr content as well as R.Address.
OUTPUT:
Don't need any selections, this is just for demonstration purpose:
Output should look like this:
EDIT...
Suppose the duplicate values were same across the rows? So only duplicate columns values to be merged. There has to be an quick, innovative way to do this merge.
Final Output Image:
The issue is that your code can only find 2 adjacent cells and is not looking for a third one with this code: Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
After the first loop it adds these 2 cells
After another loop it adds the next 2 cells
And this results in an overlapping
which you can see at the darker shading of the selection.
I just edited some part of your code with comments, so you can see how it could be done. But I'm sure there is still space for improvements.
Sub MergeCellsNew()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant
ReDim arr(1 To 1) As Variant
With ThisWorkbook.Sheets("tst")
Set Rng = .Range("A2:D11")
lRow = Rng.End(xlDown).Row
For J = 1 To 4
I = 2 'I = Rng.Row to automatically start at the first row of Rng
Do While I <= lRow
Set R = .Cells(I, J) 'remember start cell
'run this loop as long as duplicates found next to the start cell
Do While Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I + 1, J)))
Set R = R.Resize(R.Rows.Count + 1) 'and resize R + 1
I = I + 1
Loop
'now if R is bigger than one cell there are duplicates we want to add to the arr
'this way single cells are not added to the arr
If R.Rows.Count > 1 Then
arr(UBound(arr)) = R.Address
ReDim Preserve arr(1 To UBound(arr) + 1)
End If
I = I + 1
Loop
Next J
ReDim Preserve arr(1 To UBound(arr) - 1)
Set R = .Range(Join(arr, ","))
With R
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Stop
End With
Application.DisplayAlerts = True
End Sub
I am trying to make edge relation from excel file which are organized in rows,
A,B,C,
D,E
the aim is to create relationships from each row:
A,B
A,C
B,C
I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):
D," "
E, " "
Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.
Thank you so much,Will be great help.
My code:
Sub Transform()
Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2
Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long
Dim sourceRow As Range: For Each sourceRow In Selection.Rows
For colCounter = 1 To Selection.Columns.Count - 1
col1 = sourceRow.Cells(colCounter).Value
For colCounter2 = colCounter + 1 To Selection.Columns.Count
Set cell = sourceRow.Cells(, colCounter2)
If Not cell.Column = Selection.Column Then
Selection.Worksheet.Cells(targetRowNumber, 1) = col1
Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
targetRowNumber = targetRowNumber + 1
End If
Next colCounter2
Next colCounter
Next sourceRow
End Sub
I've played around with it - this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:
Sub Transform_New()
Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer
Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range
varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell
k = j
Do Until varArray(i, k) = ""
k = k + 1
If varArray(i, k) <> "" Then
rngDest.Value = varArray(i, j)
rngDest.Offset(0, 1).Value = varArray(i, k)
Set rngDest = rngDest.Offset(1, 0)
End If
Loop
Next
Next
End Sub