So I have something like this:
A B C ...
1 11 12 13
2 10 20 15
3 1 -8 -2
...
So A3, B3, and C3 is generated by subtracting A1 to A2 and so on.
If you look at the top of the sheet there is a long formula bar that shows the formula of a cell when you click on one. If you are filling in the sheet manually, you can type in that bar something like = A1 - A2 and it will fill A3 for you.
In my case, I am using .Formula = "IFERROR(A1 - A2, ""N/A""") in my code.
The problem I am having is that when the sheet is generated, instead of the desired output shown above, it is displaying something like this
A B C ...
1 11 12 13
2 10 20 15
3 #NAME? #NAME? #NAME?
...
If I click on the cell, the formula bar actually shows that it is apply the correct formula, and if I hit Enter after clicking on the formula bar, the correct numbers show up. So it's like I'm manually entering the formula.
This is my code. ConvertToLetter() takes in an integer and convert to column character.
Public Function ProcessExcelRpt(dataArray(,) As Object) As Integer
Dim ws As Worksheet
Dim r As Range
Try
For i As Integer = 1 To xlWorkBook.Sheets.Count
ws = xlWorkBook.Sheets(i)
r = ws.Range("A8")
ws.Range("A8").Resize(dataArray.GetUpperBound(0) + 1, dataArray.GetUpperBound(1) + 1).Value2 = dataArray
ws.Range("A2").Value2 = ws.Range("A2").Value2.ToString() & FormatDate(ReportDate, "MMMM dd, yyyy")
FormatColumns(ws, 8, dataArray.GetUpperBound(0) + 8)
excel.CalculateFull()
xlWorkBook.SaveAs(saveAs)
Exit For
Next
Catch ex As Exception
Return -1
End Try
Return 0
End Function
Public Sub FormatColumns(ws As Worksheet, ByVal firstRow As Integer, ByVal lastRow As Integer)
Dim rng As Range
Try
Dim colCnt, rowCnt, i As Integer
i = 0
For rowCnt = firstRow To lastRow
Dim row1, row2 As Integer
row1 = rowCnt - 2 ' go back 2 rows
row2 = rowCnt - 1 ' go back 1 row
' Apply formula to each cell in each row
For colCnt = 1 To 3
rng = ws.Range(ConvertToLetter(colCnt) & rowCnt) ' A1 for ex
rng.Formula = "=IFERROR(" & ConvertToLetter(colCnt) & row1 & "-" & ConvertToLetter(colCnt) & row2 & ", ""N/A"")"
Next
Next
Catch ex As Exception
End Try
End Sub
If you run this as a Sub it is working for me:
Sub foo(firstRow, lastRow)
Dim rng As Range
For rowCnt = firstRow To lastRow
Dim row1, row2 As Integer
row1 = rowCnt - 2 ' go back 2 rows
row2 = rowCnt - 1 ' go back 1 row
' Apply formula to each cell in each row
For colCnt = 1 To 3
Set rng = Cells(rowCnt, colCnt) ' A1 for ex
rng.Formula = "=IFERROR(" & Cells(row1, colCnt).Address & "-" & Cells(row2, colCnt).Address & ", ""N/A"")"
Next
Next
End Sub
If you are trying to execute this from a Function call as a UDF, it will not work because of explicit limitations on what UDFs can manipulate on the worksheet, specifically that you cannot:
Change another cell's value.
https://support.microsoft.com/en-us/kb/170787
Related
I have a macro that is working 99% of the time, but giving me trouble with one portion. I have data that is split into different size groups depending on certain parameters. The groups range from 1 row to as many at 10+. I am trying to copy each of the "groups" and paste into a template sheet and save which I've figured out.
Row Column B Column C
1 ASDF a
2 SDF a
3 WIRO a
4 VNDH a
5
6 FIJDK b
7 DFKIEL b
8
9 DLFKD c
10
11 OYPTK d
12 SSAODKJ d
13 SKJSJ d
Where I'm having trouble is Row 9 where Column b B = DLFKD and Column C = C
Desired Output:
Copy only row 9
Actual Output:
Copying Rows 9- 11
Existing Macro:
Data begins on Row 5.
Sub templatecopy()
Dim x As Workbook
Dim y As Workbook
Dim N As Long
Dim name As String
'## Open both workbooks first:
Set x = ActiveWorkbook
'Set R
R = 5
'start Loop
Do Until N = 96
Set y = Workbooks.Open("F:\Logistics Dashboard\Customs Macro\Cover Sheet Template.xlsx")
'set N
N = Range("B" & R).Cells(1, 1).End(xlDown).Row
'Now, copy Container Numbers from x and past to y(template):
x.Sheets("Sheet1").Range("B" & R & ":C" & N).Copy
y.Sheets("Sheet1").Range("A14").PasteSpecial
'save as Name of Vessel
name = "F:\Logistics Dashboard\Customs Macro\" & y.Sheets("Sheet1").Range("A14").Value & ".xlsx"
ActiveWorkbook.SaveAs Filename:=name
'Close template after saving to reset:
y.Close
'set R equal to new row to start
R = N + 2
Loop
End Sub
The issue is with how I am setting "N". Its having trouble distinguishing Row 9 where its just one row of data.
With the correct sheet selected this line of code should select the ranges on your sheet:
Thisworkbook.Worksheets("Sheet1").range("B:C").specialcells(xlcelltypeconstants,23).select
You'll need to add another line to account for formula as well as constants.
Public Sub FindRegionsOnSheet()
Dim sAddress As String
Dim aAddress() As String
Dim vItem As Variant
Dim x As Long
Dim wbTarget As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wbTarget = Workbooks.Open("F:\Logistics Dashboard\Customs Macro\Cover Sheet Template.xlsx")
Set wsTarget = wbTarget.Worksheets("Sheet1")
'Find all ranges of constant & formula values in column B:C.
With wsSource.Columns(2).Resize(, 2)
On Error Resume Next
sAddress = .SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
sAddress = sAddress & .SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
If Right(sAddress, 1) = "," Then sAddress = Left(sAddress, Len(sAddress) - 1)
On Error GoTo 0
End With
'Place within an array.
If Not sAddress = vbNullString Then
If InStr(1, sAddress, ",") = 0 Then
ReDim aAddress(0 To 0)
aAddress(0) = "'" & wsSource.Name & "'!" & sAddress
Else
aAddress = Split(sAddress, ",")
For x = LBound(aAddress) To UBound(aAddress)
aAddress(x) = "'" & wsSource.Name & "'!" & aAddress(x)
Next x
End If
End If
''''''''''''''''''''''''''''''''''''''''
'Not sure how what you're doing once moved to the Target book......
'Think this is correct, but test first...
''''''''''''''''''''''''''''''''''''''''
For Each vItem In aAddress
wsTarget.Cells.Clear
Range(vItem).Copy Destination:=wsTarget.Range("A14")
wbTarget.SaveCopyAs "F:\Logistics Dashboard\Customs Macro\" & wbTarget.Sheets("Sheet1").Range("A14") & ".xlsx"
Next vItem
wbTarget.Close
End Sub
The 23 in the SpecialCells indicates what types of cells to include in the result:
XlSpecialCellsValue constants Value
xlErrors 16
xlLogical 4
xlNumbers 1
xlTextValues 2
These values can be added together to return more than one type (total = 23). The default is to select all constants or formulas, no matter what the type.... so probably don't need the 23 at all.
I have a gigantic table in excel(720x720) in which I want to find non-zero values. when the value is found I would like to get the first two cells of this row on a new sheet on two columns, the cell in question on a third and the first two cells in the columns of the cell I'm looking for on two other columns.
For example if my values are in E26 R89 and Z9 on sheet 1 I would like to get a table on sheet 2 that would look like this:
A B C D E
1 A26 B26 E26 E1 E2
2 A89 B89 R89 R1 R2
3 A9 B9 Z9 Z1 Z2
Here is what I've tried so far (please bear in mind that you are talking to a beginner)
Sub tests_selection()
Dim r As Worksheet
Dim c As Workbook, f As Worksheet
Set c = Workbooks("classeur1")
Set f = c.Worksheets("feuil1")
Dim a(5200)
Dim b
b = 0
Range("A1:AAU723").Select
For i = 4 To 720
For j = 4 To 723
If f.Cells(i, j).Value <> 0 Then
a(b) = f.Cells(i, j).Adress
b = b + 1
End If
Next j
Next i
Set r = c.Worksheets("result")
For i = 0 To b
r.Cells(i, 1).Value = a(i)
Next i
End Sub
Table example
Result example
First of all you should use meaningful variable names instead of 1 character only. This makes your code much more understandable and readable and therefore results in less bugs.
Also use Option Explicit to force proper variable declaring.
Option Explicit
Sub tests_selection()
Dim SrcWs As Worksheet
Set SrcWs = Worksheets("feuil1") 'source worksheet
Dim ResultWs As Worksheet
Set ResultWs = Worksheets("result") 'result worksheet
Dim rRow As Long
rRow = 2 'start row in result sheet
Dim iCell As Range
For Each iCell In SrcWs.Range("C4:AN40") '<-- make sure to adjust the range to the data only! so header rows are not included
If iCell.Value <> 0 Then
ResultWs.Cells(rRow, 1).Value = SrcWs.Cells(iCell.Row, 1).Value
ResultWs.Cells(rRow, 2).Value = SrcWs.Cells(iCell.Row, 2).Value
ResultWs.Cells(rRow, 3).Value = iCell.Value
ResultWs.Cells(rRow, 4).Value = SrcWs.Cells(1, iCell.Column).Value
ResultWs.Cells(rRow, 5).Value = SrcWs.Cells(2, iCell.Column).Value
rRow = rRow + 1
End If
Next iCell
End Sub
In VBA Excel, if I have a table. How do I check the cells outside the table in all 4 sides of it, for 10 rows and 10 columns, as empty or not?
Thanks
Jeevan
You could use this function:
Option Explicit
Function NonBlankCellsOutside(rng As Range, rowsOutside As Long, colsOutside As Long)
Dim outside As Range
Dim rowsBefore As Long
Dim colsBefore As Long
rowsBefore = IIf(rng.Row <= rowsOutside, rng.Row - 1, rng.Row - rowsOutside)
colsBefore = IIf(rng.Column <= colsOutside, rng.Column - 1, rng.Column - colsOutside)
Set outside = rng.Offset(-rowsBefore, -colsBefore) _
.Resize(rng.Rows.Count + rowsBefore + rowsOutside, _
rng.Columns.Count + colsBefore + colsOutside)
NonBlankCellsOutside = WorksheetFunction.CountA(outside) _
- WorksheetFunction.CountA(rng)
End Function
Example use with a normal range:
Dim ok As Boolean
ok = NonBlankCellsOutside(Worksheets(1).Range("C20:F50"), 10, 10) = 0
If Not ok Then MsgBox "There are non-blank cells in the neighbourhood"
Another example with a named table:
Dim num As Long
num = NonBlankCellsOutside(ActiveSheet.ListObjects("Table1").Range, 5, 5)
MsgBox "There are " & num & " non-blank cells around the table"
You can do this with in-cell formulae.
Given a table named Table1 whose top-left corner is no closer to the top or to the left than K11, and the following formulae, the value in A5 will give you your answer:
A B C
1
2 Range start =ROW(Table1)-10 =COLUMN(Table1)-10
3 Range end =ROW(Table1)+ROWS(Table1)+9 =COLUMN(Table1)+COLUMNS(Table1)+9
4
5 =AND(B2>0, B3>0, COUNTA(INDIRECT("r"&B2&"c"&C2&":r"&B3&"c"&C3, FALSE))=COUNTA(Table1[#All]))
Here I have something that works for any named table, as long as its first cell is no closer to the edges than K11.
Sub checkSurroundings()
Dim tws As Worksheet
Dim tb1 As ListObject
Dim tb1_address As String
Dim c() As String 'Table range, first and last cell
Dim rngL, rngR, rngU, rngD As Range
Dim tmpRange As Range
Dim cnt As Integer
Set tws = ThisWorkbook.Worksheets("Sheet1")
Set tb1 = tws.ListObjects("Table1")
tb1_address = tb1.Range.Address
'Debug.Print tb1_address
c() = Split(tb1_address, ":", -1, vbTextCompare)
'Debug.Print c(0)
'Debug.Print c(1)
cnt = 0
With tws
'Range Left
Set rngL = Range(.Range(c(0)).Offset(-10, -10), .Cells(.Range(c(1)).Row + 10, .Range(c(0)).Column - 1))
'Range Right
Set rngR = Range(.Cells(.Range(c(0)).Row - 10, .Range(c(1)).Column + 1), .Range(c(1)).Offset(10, 10))
'Range Up
Set rngU = Range(.Range(c(0)).Offset(-10, 0), .Cells(.Range(c(0)).Row - 1, .Range(c(1)).Column))
'Range Down
Set rngD = Range(.Cells(.Range(c(1)).Row + 1, .Range(c(0)).Column), .Range(c(1)).Offset(10, 0))
End With
For i = 1 To 4
Select Case i
Case 1
Set tmpRng = rngL
Case 2
Set tmpRng = rngR
Case 3
Set tmpRng = rngU
Case 4
Set tmpRng = rngD
End Select
For Each cell In tmpRng
If Not IsEmpty(cell) Then
cnt = cnt + 1
End If
Next cell
Next i
If cnt > 0 Then
MsgBox ("The area around Table1 (+-10) is not empty. There are " & cnt & " non-empty cells.")
Else
MsgBox ("The area around Table1 (+-10) is empty.")
End If
End Sub
Is there any efficient way or a correct way to copy and paste within the same worksheet? My code:
With ActiveWorkbook.Sheets("Sheet1")
For Each row In .Rows
If Not row.Columns("A:A") Is Empty Then 'error here
.Columns("A:A").Copy .Range("B1")
End If
Next rw
.Columns("A:A").Delete
End With
So in the code above, I would like to replace the column B with Column A only when the Column A of the cell is NOT empty.
For example:
1 Nil
Nil
24
4 Nil
4 Nil
12
3
7 Nil
2
Nil
8 Nil
Final result will be like this in Column B:
1
Nil
24
4
4
12
3
7
2
Nil
8
EDIT: Never mind, Solved.
With ActiveWorkbook.Sheets("Sheet1")
For rw = 1 To .Rows.Count
If (.Rows(rw).Columns("A:A").Value <> "") Then
.Rows(rw).Columns("A:A").Copy .Range("B" & rw)
End If
Next rw
.Columns("A:A").Delete
End With
With ActiveWorkbook.Sheets("Sheet1").UsedRange
For Each Row In .Rows
If Row.Cells(1, 1) <> "" Then
Row.Cells(1, 2) = Row.Cells(1, 1)
End If
Next
.Columns("A:A").Delete
End With
If you want to fire the the method when any cell from column changes use the method
Worksheet_Change, Here we are catching any change over the cell in the column J only
In this example we copy the values from the column E to G, without including the empty cells. We clear first the column G if this has any old value using this command Worksheets("Sheet1").Range("G:G").ClearContents
Private Sub Worksheet_Change(ByVal Target As Range)
idx = ActiveCell.Row
idxStr = CStr(idx)
labelIdx = "J" + idxStr
Dim ii As Long
Dim columnNumber As Long
ii = 1
columnNumber = 10
If ActiveCell.Column = columnNumber And ActiveCell.Value <> "" Then
Worksheets("Sheet1").Range("F1") = Range(labelIdx).Value
Worksheets("Sheet1").Range("G:G").ClearContents
For Each cell In Worksheets("Sheet1").Range("E:E")
If cell.Value <> "" And cell.Value <> "COLUMN LABEL" Then
Worksheets("Sheet1").Range("G" + CStr(ii)).Value = cell.Value
ii = ii + 1
End If
Next cell
End If
End Sub
(VB Express Level: Beginner)
I want to do following,
A column from Workbook 1
a
b
c
d
A column from Workbook2
e
f
g
h
Output to a single cell
ae+bf+cg+dh
(The output is a Sumproduct.)
There are 44 rows in workbook 1 and 44 rows in workbook 2. But there are 3 columns in workbook 1 and 104 columns in workbook 2. Each column in workbook 3 must be multiplied with 104 columns from workbook 2.
Following is my effort, which writes sames values in all the cells of a column. My understanding is my for loop is wrong somewhere. But I am not able to figure out what is wrong.
'link to workbooks
oWB5 = oXL5.Workbooks.Open("D:\1.xlsx")
oWB6 = oXL6.Workbooks.Open("D:\2.xlsx")
oWB7 = oXL7.Workbooks.Open("D:\outputs.xlsx")
'link to worksheets
oSheet5 = oWB5.Worksheets("Inputs")
oSheet6 = oWB6.Worksheets("Coef")
oSheet7 = oWB7.Worksheets("Sheet1")
' ranges to be considerd,
' oWB5 range C22 to C66
' oWB6 range C3 to C47
' oWB7 range C2 to C104 (because there are 104 columns in oWB6)
'multiplication of ranges
For j = 3 To 47
For i = 2 to 104
For k = 2 to 4
For l = 22 to 66
oSheet7.Cells(i, k).Value = (oSheet5.Cells(l, k).value * oSheet6.Cells(j, i+1).value) + (oSheet5.Cells(l+1, k).value * oSheet6.Cells(j + 1, i+1).value)
Next
Next
Next
Next
Help will be really appreciated. I am struggling with this for two days now.
Here is a simple method using the Excel's SUMPRODUCT formula. This way you let Excel do the dirty work for you. The advantage of this is that it saves you a lot of looping :)
TRIED AND TESTED
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim xlApp As New Excel.Application
Dim oWB5 As Excel.Workbook = xlApp.Workbooks.Open("C:\1.xlsx")
Dim oWB6 As Excel.Workbook = xlApp.Workbooks.Open("C:\2.xlsx")
Dim oWB7 As Excel.Workbook = xlApp.Workbooks.Open("C:\outputs.xlsx")
Dim oSheet7 As Excel.Worksheet = oWB7.Worksheets("Sheet1")
With oSheet7
For i = 1 To 8
For j = 1 To 104
Dim Col1Nm As String = Split(.Cells(, j).Address, "$")(1)
Dim Col2NM As String = Split(.Cells(, i).Address, "$")(1)
.Cells(i, j).Value = xlApp.Evaluate("=SUMPRODUCT(([1]Inputs!" & Col1Nm & "1:" & _
Col1Nm & "44)*([2]Coef!" & Col2NM & "1:" & Col2NM & "44))")
Next
Next
End With
'~~> Close workbook and quit Excel
oWB5.Close (False)
oWB6.Close (False)
oWB7.Close (True)
xlApp.Quit()
'~~> Clean Up
releaseObject (oWB5)
releaseObject (oWB6)
releaseObject (oWB7)
releaseObject (xlApp)
MessageBox.Show("done")
End Sub
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject (obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class
IMP NOTE: If your actual file names are not 1.xlsx and 2.xlsx then change this part of the code
xlApp.Evaluate("=SUMPRODUCT(([1]Inputs!" & Col1Nm & "1:" & _
Col1Nm & "44)*([2]Coef!" & Col2NM & "1:" & Col2NM & "44))")
Replace
[1] by [Actual File Name]
[2] by [Actual File Name]
Inputs by [Actual Sheet Name] and
Coef by [Actual Sheet Name]
Thanks for re-posting this question with more detail.
I've written a loop bellow with comments that i believe achieves what you're looking to do.
'link to workbooks
oWB5 = oXL5.Workbooks.Open("D:\1.xlsx")
oWB6 = oXL6.Workbooks.Open("D:\2.xlsx")
oWB7 = oXL7.Workbooks.Open("D:\outputs.xlsx")
'link to worksheets
oSheet5 = oWB5.Worksheets("Inputs")
oSheet6 = oWB6.Worksheets("Coef")
osheet7 = oWB7.Worksheets("Sheet1")
' ranges to be considerd,
' oWB5 range C22 to C66
' oWB6 range C3 to C47
' oWB7 range C2 to C104 (because there are 104 columns in oWB6)
'multiplication of ranges
Dim lngOutputCounter As Long
For i = 1 To 104 'for each column WB6
For j = 1 To 3 'for each column WB5
lngOutputCounter = 0 'reset to 0
For k = 1 To 44 'loop through 44 rows
'multiply the two cells and keep a running total
'- 21+k to start at row 22, 2+k to start at row 3, 2+j and 2+i because columns start at C
lngOutputCounter = lngOutputCounter + oSheet5.Cells(21 + k, 2 + i).Value * oSheet6.Cells(2 + k, 2 + j).Value
Next k
'whatever column sheet2 was on becomes row here, j is still the same column (1-3)
'- i+i to output to row 2 first, 2+j to output to column C first
osheet7.Cells(1 + i, 2 + j).Value = lngOutputCounter
Next j
Next i