After the vba macro is running only the values sholud be visible into the cells. In addtional all special character #N/A" should be removed. Everywhere where #N/A stands should then be an empty field.
Dim sh As Worksheet, shOld As Worksheet, shNew As Worksheet, lastR As Long, rngB As Range
Dim rngBJ As Range, rngBN As Range, lastR2 As Long, lastR3 As Long, arrVlk, iRow As Long, i As Long, l As Long
iRow = 5 'the row where from the data will be returned
Set sh = Worksheets("PIV Kunde SO & Status")
Set shOld = Worksheets("oldStockAge")
Set shNew = Worksheets("PIV Kunde SO, Vendor & Age")
lastR = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
lastR2 = shOld.Range("B" & sh.Rows.Count).End(xlUp).Row
lastR3 = shNew.Range("B" & sh.Rows.Count).End(xlUp).Row
Set rngB = sh.Range("B" & iRow & ":B" & lastR)
Set rngBJ = shOld.Range("B5:J" & lastR2)
Set rngBN = shNew.Range("B2:F" & lastR3)
For l = 2 To 6
sh.Cells(iRow, l + 2).Formula = "=VLOOKUP(B5," & rngBN.Address(external:=True) & "," & l & ",0)"
Next l
sh.Range("D" & iRow, "F" & iRow).AutoFill Destination:=sh.Range("D" & iRow, "F" & lastR)
For i = 7 To 9
sh.Cells(iRow, i + 1).Formula = "=VLOOKUP(B5," & rngBJ.Address(external:=True) & "," & i & ",0)"
Next i
sh.Range("D" & iRow, "I" & iRow).AutoFill Destination:=sh.Range("D" & iRow, "I" & lastR)
Please, add to the end of your existing code the next lines:
Dim rngNA as Range
On Error Resume Next 'just to avoid a code error in case of no #N/A return...
set rngNa = sh.Range("D" & iRow, "I" & lastR).SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rngNA Is Nothing Then rngNA.Value = ""
Or try adapting the formula to return an empty string in case of no match, in the next way:
Dim strFormula As String
For l = 2 To 6
strFormula = "VLOOKUP(B5," & rngBN.Address(external:=True) & "," & l & ",0)"
sh.cells(iRow, l + 4).Formula = "=If(ISNA(" & strFormula & "),""""," & strFormula & ")"
Next l
strFormula is used only to avoid a big 'sausage' formula... :)
Related
I have a CSV file that contains lots of tables inside of one worksheet. I was writing parts of the code in one procedure to check if it was doing what I expected for each table. The final result I pasted in one single procedure and now I'm getting a Compile Error right in the beginning of the code, in "Sub IP_VBA()", and I have no idea how to solve it, can someone help me?
If I run it part by part, it does what I want, but not when I put all the code together.
Sub IP_VBA()
' Format IP table
Dim LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, LR5 As Long
Dim FR1 As Long, FR2 As Long, FR3 As Long, FR4 As Long
Dim Rows As Long, i As Long
Dim Data As Range
'Delete tables 1, 2 and 3
Rows("1:3").EntireRow.Delete
Rows("1:1").Select
Range(Selection, Selection.End(xlDown).Offset(1, 0)).Delete Shift:=xlUp
Rows("1:2").EntireRow.Delete
Columns("A:I").EntireColumn.Delete
'Get necessary data from table 4
LR1 = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
Range("B1:B" & LR1 & "," & "D1:E" & LR1 & "," _
& "G1:O" & LR1).Delete Shift:=xlToLeft
'Delete table 5
Rows(LR1 + 2).Select
Range(Selection, Selection.End(xlDown).Offset(1, 0)).Delete Shift:=xlUp
'Get necessary data from table 6
FR1 = Range("A" & LR1).Offset(2, 0).Row
Rows(FR1).EntireRow.Delete
LR2 = ActiveSheet.Range("A" & FR1).CurrentRegion.Rows.Count + LR1 + 1
Range("A" & FR1 & ":B" & LR2 & "," & "E" & FR1 & ":J" & LR2 & "," & _
"L" & FR1 & ":T" & LR2).Delete Shift:=xlToLeft
'Get necessary data from tables 7 and 8
FR2 = Range("A" & LR2).Offset(2, 0).Row
Rows(FR2).EntireRow.Delete
LR3 = ActiveSheet.Range("A" & FR2).CurrentRegion.Rows.Count + LR2 + 1
FR3 = Range("A" & LR3).Offset(2, 0).Row
Rows(FR3).EntireRow.Delete
LR3 = ActiveSheet.Range("A" & FR3).CurrentRegion.Rows.Count + LR3 + 1
Range("A" & FR2 & ":D" & LR3 & "," & "G" & FR2 & ":L" & LR3 & "," & _
"N" & FR2 & ":V" & LR3).Delete Shift:=xlToLeft
'Delete table 9
FR4 = Range("A" & LR3).Offset(2, 0).Row
LR4 = ActiveSheet.Range("A" & FR4).CurrentRegion.Rows.Count + LR3 + 1
Range("A" & FR4 & ":W" & LR4).Delete Shift:=xlToLeft
'Delete Empty Rows
LR5 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Set Data = ActiveSheet.Range("A1:C" & LR5)
Rows = Data.Rows.Count
For i = Rows To 1 Step (-1)
If WorksheetFunction.CountA(Data.Rows(i)) = 0 Then Data.Rows(i).Delete
Next
'Rename Columns
Range("A1").Formula = "Part Number"
Range("B1").Formula = "IP Qty"
Range("C1").Formula = "IP Value"
End Sub
You have
Dim Rows As Long
but then
Rows("1:3").EntireRow.Delete
I would not use Rows as a variable name, and also use a specific worksheet qualifier for any and all calls to Rows/Range/Cells/Columns
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Rows("1:3").EntireRow.Delete
'etc
i am trying to copy selected cells rows , together with the header over to another cell. however, the most i can copy is up to 4 rows, else i will receive the range of object global failed error message. may i know why i am unable to select 5 rows and above? thank you in advance.
Sub CopyPaste()
Dim NumRowSelected As Integer
Dim i As Integer
Dim currentCell As Range
Dim bottomCell As Range
Dim ToSelect As Range
Dim k As Integer
Dim selectedString As String
Windows("Book1.xlsx").Activate
Sheets("working").Select
NumRowSelected = Selection.Rows.Count
selectedString = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1,K1,L1,M1,N1,O1"
k = 2
i = 0
Set currentCell = Range("A2")
Set bottomCell = Range("A2").End(xlDown)
Do While k <= bottomCell.Row
For Each cell In Selection
If currentCell = cell Then
selectedString = selectedString & ",A" & k & ",B" & k & ",C" & k & ",D" & k & ",E" & k & ",F" & k & ",G" & k & ",H" & k & ",I" & k & ",J" & k & ",K" & k & ",L" & k & ",M" & k & ",N" & k & ",O" & k
i = i + 1
If i = NumRowSelected Then
Exit Do
End If
Exit For
End If
Next cell
k = k + 1
Set currentCell = Range("A" & k)
Loop
Set a = Range(selectedString)'error code shows here
a.Select
Range("A1").Activate
Selection.Copy
Range("Q1").Select
ActiveSheet.Paste
Selection.Copy
End Sub
The address you pass to the Range property is limited to 255 characters, which you will easily bypass with your method. You can condense it quite a lot since your cells are contiguous within a row by using:
selectedString = selectedString & ",A" & k & ":O" & k
and start with:
selectedString = "A1:O1"
but it would be safer to use a Range object with Union:
If a is Nothing then
Set a = Range("A" & k).Resize(1, 15)
else
set a = Union(a, Range("A" & k).Resize(1, 15))
end if
I have a substring in the column "A" of Sheet2, which I take using the LEFT Function. This is changing at every import and I'm trying to find it in the column "AI" of Sheet1. Then I want to copy the columns from "AI" to "AF" from Sheet1 and paste them in Sheet2. What am I doing wrong?
Sub InStrDemo()
Dim lastrow As Long
Dim i As Integer, icount As Integer
Dim LResult As String
LResult = Sheets("Sheet2").Range("A2")
LResult = Left(LResult, 4)
lastrow = Sheets("Sheet1").Range("A30000").End(xlUp).Row
icount = 1
For i = 2 To lastrow
If InStr(1, LCase(Range("AI" & i)), LCase(LResult)) <> 0 Then
icount = icount + 1
Sheets("Sheet2").Range("B" & icount & ":E" & icount) =
Sheets("Sheet1").Range("AF" & i & ":AI" & i).Value
End If
Next i
End Sub
You are trying to copy and paste, after = it should be _ if you are trying to compare. See if it works:
Sheets("Sheet2").Range("B" & icount & ":E" & icount) = _
Sheets("Sheet1").Range("AF" & i & ":AI" & i).Value
I am trying to reformat a report so it can feed into my system like below:
wbOutput.Sheets(1).Range("B" & O_lrow + 1 & ":B" & O_lrow + lRow).Value = wbSource.Sheets(1).Range("F1:F" & lRow).Value
One issue I encounter is column F needs to be the sum of two source column and below doesn't work:
wbOutput.Sheets(1).Range("F" & O_lrow + 1 & ":F" & O_lrow + lRow).Value = wbSource.Sheets(1).Range("N1:N" & lRow).Value + wbSource.Sheets(1).Range("O1:O" & lRow).Value
I am trying to avoid using loop as there are many rows and I don't want the marco slow down too much.
Is there any simple way to achieve this without using a loop?
You can try this:
wbOutput.Sheets(1).Range("F" & O_lrow + 1 & ":F" & O_lrow + lRow).Value = _
wbSource.Sheets(1).Evaluate("N1:N" & lRow & " + O1:O" & lRow)
This is a way, using the Application.Sum function:
Option Explicit
Sub SumTest()
Dim SumA As Range
Dim SumB As Range
With wbSource.Sheets(1)
Set SumA = .Range("N1:N" & lRow)
Set SumB = .Range("O1:O" & lRow)
End With
wbOutput.Sheets(1).Range("F" & O_lrow + 1 & ":F" & O_lrow + lRow) = Application.Sum(SumA, SumB)
End Sub
You already have two good answers, just want to add my 2 cents here...
If you have lots of data, you should consider using arrays, and one way of doing what you are trying to achieve can be the below, please see comments for further details:
Dim wsOutput As Worksheet: Set wsOutput = wbOutput.Sheets(1) 'allocate the output worksheet to a variable
Dim wsSource As Worksheet: Set wsSource = wbSource.Sheets(1) 'allocate the source worksheet to a variable
Dim arrSource As Variant
Dim arrOutput() As Variant 'Could change this to match your expected data type output
Dim R As Long, C As Long
arrSource = wsSource.Range("N1:O" & lRow) 'Get the source data into an array
ReDim arrOutput(1 To UBound(arrSource), 1 To 1) 'set the size of the output
For R = 1 To UBound(arrSource)
For C = 1 To UBound(arrSource, 2)
arrOutput(R, 1) = arrSource(R, 1) + arrSource(R, 2) 'make your calculations here
Next C
Next R
wsOutput.Range("F" & O_lrow + 1 & ":F" & O_lrow + lRow) = arrOutput 'spit it back to the sheet once is done
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub