Column K can contain the string 'Item Cost'. When Column K contains 'Item Cost' I would like to offset to Column U and copy the value from that cell within the same ROW as the string 'Item Cost'.
I can get the code to read and find the value in Column K, but am having a problem with the coping portion of the code for Column U.
Dim range1 As Range
Dim Answer4 As Variant
LstRw = Cells(Rows.Count, "K").End(xlUp).Row
Set List = CreateObject("Scripting.Dictionary")
For Each range1 In wbFrom.Sheets("Sheet0").Range("K9:K" & LstRw)
If range1.Offset(0, 0) = "Item Cost " Then
'MsgBox "found"
Answer4 = range1.Offset(0, 10).Value '<---- PROBLEM
End If
Next
'Msgbox Answer4 'returns nothing
wbTo.Sheets("Sheet1").Range("D10").Value = Answer4 'returns nothing
Seems like you will want to make your destination range dynamic (Range("D10")). The code as is will continousely re-write over your value in D10. Do you maybe want the value to be in Col D on the same row as the target range? If so, swap
wbTo.Sheets("Sheet1").Range("D10") = range1.Offset(0, 10)
for
wbTo.Sheets("Sheet1").Range("D" & range1.Row) = range1.Offset(0, 10)
For Each range1 In wbFrom.Sheets("Sheet0").Range("K9:K" & LstRw)
If range1 = "Item Cost " Then
'MsgBox "found"
wbTo.Sheets("Sheet1").Range("D10") = range1.Offset(0, 10)
End If
Next
Related
I would like to know how to manipulate my excel data as I need.
I have a table with rows and a lot of field I would like to select by hand some rows and to copy them to another sheet that has predefined column ordering those rows to fit my predefined column and to create an unique code for rows that I consider duplicate based on 2 two column.
This might not be very clear so I will explain more with photo:
here I have my table with rows I selected by hand, I would like to copy column H,I,K,AA,AJ to another sheet but in some specific order to fit my other table column:
I would like my AJ column in the Column A, my AA column in the Column E My column K in the Column F etc...
I Would also want to create a unique Key based on column F and I (for example here in the first image rows 17 to 21 would have the same key in the blue sheet in column B)
For the moment I am able to take my selected rows and copy the wanted column to another sheet.
I don't know how to reorder them to fit my template in the second sheet. I also don't know how to create a key and insert it to my second sheet for each combination of columns F and I of my first sheet.
Sub ajout_commande()
Set DataSheet = ThisWorkbook.Worksheets("0")
Dim a As Range, b As Range
Set a = Selection
i = Selection.Rows.Count
For Each b In a.Rows
DataSheet.Cells(2, 1).EntireRow.Insert
Next
Dim r1 As Range, r2 As Range, r3 As Rang, r4 As Range, r5 As Range, res_range As Range
Let copyrange1 = "I1" & ":" & "I" & i
Let copyrange2 = "K1" & ":" & "K" & i
Let copyrange3 = "L1" & ":" & "L" & i
Let copyrange4 = "AA1" & ":" & "AA" & i
Let copyrange5 = "AJ1" & ":" & "AJ" & i
Set r1 = a.Range(copyrange1)
Set r2 = a.Range(copyrange2)
Set r3 = a.Range(copyrange3)
Set r4 = a.Range(copyrange4)
Set r5 = a.Range(copyrange5)
Set res_range = Union(r1, r2, r3, r4, r5)
res_range.Copy
DataSheet.Cells(2, 1).PasteSpecial xlPasteValues
End Sub
If this is to complicate to implement or impossible please tell me in comment so that I try to find another method. I am new to VBA and am trying to help my colleagues by simplifying their work.
Thanks.
Maybe try something like this.
It need some adjustements (especially in cells to copy)
Dim UniqueKeyArray() As String
Dim Counter As Long
Sub test()
Dim aRows As Range, aCell As Range
Dim Ws As Worksheet
Dim i As Long
Set Ws = ThisWorkbook.Sheets("SomeName")
ReDim UniqueKeyArray(0 To 1, 1 To 1)
For i = 1 To Selection.Areas.Count 'loop through selection
For Each aRows In Selection.Areas(i).Rows 'loop through rows of selection
For Each bCell In aRows.Columns(1).Cells 'loop through cells in column one
With Ws
.Cells(2, 1).EntireRow.Insert
'adjust offset to get source data you need
'adjust cells(x,y) to put data where you want it
.Cells(2, 2) = bCell.Offset(0, 2)
.Cells(2, 3) = bCell.Offset(0, 3)
.Cells(2, 4) = bCell.Offset(0, 5)
.Cells(2, 5) = bCell.Offset(0, 6)
.Cells(2, 1) = "'" & UniqueKey(bCell.Text) ' "'" added to prevent excel trim leading 000..
End With
Next bCell
Next aRows
Next i
'reset variables. This way you always start unique key from 1
Counter = 0
Erase UniqueKeyArray
End Sub
Function UniqueKey(SourceVal As String) As String
'creates unique key based on source string
Dim i As Long
For i = 1 To UBound(UniqueKeyArray, 2)
If UniqueKeyArray(1, i) = Format(SourceVal, "0000000000") Then
'if string is same you get unique key created before
UniqueKey = UniqueKeyArray(1, i)
Exit Function
End If
Next i
'if string is new then new unique key is created
Counter = Counter + 1
ReDim Preserve UniqueKeyArray(0 To 1, 1 To Counter)
UniqueKey = Format(Counter, "0000000000") 'adjust format to fit your needs
UniqueKeyArray(0, Counter) = SourceVal
UniqueKeyArray(1, Counter) = UniqueKey
End Function
I am getting to know Excel VBA. I have a working program that uses an action button on one sheet opens a source workbook and data worksheet, selects data and puts that into a second workbook and destination sheet. I then sort the data as needed and it looks like this
Destination sheet, sorted and annotated duplicates
I am now trying to select the data based on col 2 "B" where the items are duplicated and/or not duplicated then perform an action (send an email to the manager about the staff under their control). I can get an email to work but its selecting the data that I'm having trouble with.
the output data would be col 1 & col 3 to 5 e.g.
Dear Manager1,
you staff member/s listed below have achieved xyz
Person1 22/06/2017 11/08/2017 22/08/2017
Person11 22/06/2017 11/08/2017 22/08/2017
Person15 22/06/2017 11/08/2017 22/08/2017
congratulations....
So what I hope somebody can help me with is a clue how I get to look at the data in col 2
add the Row data required to an array or something then to check the next Row add it to the same something until it is different to the next Row Pause do the action then do the next iteration. Resulting in:
Manager1 .....Person 1,11,15action
Manager10 ..... Person 10action
Manager2 ..... Person 12,16,2,25,28action
Manager3 ..... Person 13,17,26,29,3action
until last line is reached.
I am so confused with arrays / lookups and loops I have lost the plot somewhere along the way.
I have a variable lastTmp which tells me the last line of data in the set, this will vary each month.
The Range is:
Set rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).row)
The last piece of my working code is:
Dim lp As Integer
lp = 1
For Each cell In rng1
If 1 < Application.CountIf(rng1, cell.Value) Then
With cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next cell
You will be better placed to confront confusion if you do your indenting more logically. Related For / Next, If / Else / End If and With / End With should always be on the same indent level for easier reading. I rearranged your original code like this:-
For Each Cell In Rng1
If 1 < Application.CountIf(Rng1, Cell.Value) Then
With Cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With Cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next Cell
It now becomes apparent that the With Cell / End With need not be duplicated. I have further presumed that your variable lp actually was intended to hold the count. That made me arrive at the following compression of your code.
Dim Rng1 As Range
Dim Cell As Range
Dim lp As Integer
' the sheet isn't specified: uses the ActiveSheet
Set Rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each Cell In Rng1
With Cell
lp = Application.CountIf(Rng1, .Value)
.Offset(0, 4) = IIf(lp, "", "NOT ") & "duplicate : "
.Offset(0, 5) = lp
End With
Next Cell
Consider using a Dictionary or Collection, whenever, checking for duplicates.
Here I use a Dictionary of Dictionaries to compile lists of Persons by Manager.
Sub ListManagerList1()
Dim cell As Range
Dim manager As String, person As String
Dim key As Variant
Dim dictManagers As Object
Set dictManagers = CreateObject("Scripting.Dictionary")
For Each cell In Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
manager = cell.Value
person = cell.Offset(0, -1).Value
If Not dictManagers.Exists(manager) Then
dictManagers.Add manager, CreateObject("Scripting.Dictionary")
End If
If Not dictManagers(manager).Exists(person) Then
dictManagers(manager).Add person, vbNullString
End If
Next
For Each key In dictManagers
Debug.Print key & " -> "; Join(dictManagers(key).Keys(), ",")
Next
End Sub
I recommend you wanting Excel VBA Introduction Part 39 - Dictionaries
Assuming your data is as in the image
Then following code will give you result as in the image below.
Sub Demo()
Dim srcSht As Worksheet, destSht As Worksheet
Dim lastRow As Long, i As Long
Dim arr1(), arr2()
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Set srcSht = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
Set destSht = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your output sheet
arr1 = Application.Index(srcSht.Cells, [row(1:7000)], Array(2, 1)) 'See note below
arr2 = arr1
For i = 1 To UBound(arr1, 1)
If Not dict.exists(LCase$(arr1(i, 1))) Then
dict.Add LCase$(arr1(i, 1)), i
Else
arr2(i, 1) = vbNullString
arr2(dict.Item(LCase$(arr1(i, 1))), 2) = arr2(dict.Item(LCase$(arr1(i, 1))), 2) & "," & arr1(i, 2)
End If
Next
destSht.Range("A1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr2 'display result
destSht.Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
End Sub
Note : For details on assigning range to array see this.
What I am trying to accomplish here is
1) Is to iterate the values in column O and for the ones that are not null - filter the worksheet titled DATA to only show values where Column B = X and use VLOOKUP() to return the lookup values to the corresponding row in Column P
2) If column O is null then filter the sheet titled DATA to only show values where Column B <> X and use VLOOKUP() to return the lookup values to the corresponding row in Column P.
I attempted the syntax below but I am getting an error of
Method 'Rarnge' of object '_Worksheet' failed
What do I need to do differently in my code below to get the syntax to return the values I desire?
Dim destSheet As Worksheet: Set destSheet = Sheets("Main")
For i = Range("A" & Rows.Count).End(3).Row To 2 Step -1
If Not IsEmpty(Cells(i, "O").Value) Then
Sheets("Data").Select
Selection.AutoFilter
ActiveSheet.Range("$A:$C").AutoFilter Field:=2, Criteria1:="<>"
Sheets("Main").Select
Application.CutCopyMode = False
form2 = "=IFERROR(VLOOKUP(RC[-15],Lookup!C[-15]:C[-13],3,FALSE),"""")"
destSheet.Range("P:P" & lr).Formula = form2
Else
Sheets("Data").Select
Selection.AutoFilter
Sheets("Main").Select
Application.CutCopyMode = False
form3 = "=IFERROR(VLOOKUP(RC[-15],Lookup!C[-15]:C[-13],3,FALSE),"""")"
destSheet.Range("P:P" & lr).Formula = form3
End If
Next i
It was a bit hard to understand for me what you are trying to do, please correct me if I get you wrong.
First of all selecting sheets is not a preferred method while running macros, unless you intentionally do it, so avoid it.
Secondly, you don't need to filter anything, you can control it by checking conditions within your code. You don't do things physically, you do them theoretically within your code, and display the output.
Have a look at this code and ask wherever you need help to understand.
Sub VLookups()
Dim destSheet As Worksheet: Set destSheet = Sheets("Main")
Dim i As Long
Dim myVal As Variant
Set lookupRange = Sheets("Data").Range("$A:$C") 'This is your lookup range
For i = 2 To Range("O" & Rows.Count).End(xlUp).Row 'Iterate from 2nd row till last row
myVal = Application.VLookup(destSheet.Cells(i, "A").Value, lookupRange, 2, False)
If IsError(myVal) Then GoTo Skip 'If searched value not found then skip to next row
If Not IsEmpty(Cells(i, "O").Value) Then 'If Cell in Column O not empty
If myVal = "YOUR X VALUE FOR COLUMN B" Then 'If Your Column B X value exists
destSheet.Cells(i, "P").Value = Application.VLookup(destSheet.Cells(i, "A").Value, _
lookupRange, 3, False) 'Column P Cell is populated by Data Sheet Column C Cell
End If
Else 'If Cell in Column O empty
If myVal <> "YOUR X VALUE FOR COLUMN B" Then 'If Your Column B X value not exists
destSheet.Cells(i, "P").Value = Application.VLookup(destSheet.Cells(i, "A").Value, _
lookupRange, 3, False) 'Column P Cell is populated by Data Sheet Column C Cell
End If
End If
Skip:
Next i
End Sub
I need some help to create a macro which adds all the values on the column E between the rows with the "avg" word. the result should be displayed on the cells where the "Sum here" label is displayed. Both texts "avg" and "sum here" is just for illustrate the example, "avg" could be replaced by any other word and "sum here" should actually be the aggregation of the values above it.
The real challenge is that the number of ranges on column E is variable, so i would like to find a macro which is able to deal with "n" number of ranges on column E.
Finally, the values on column D are only the example of the expected value on the "sum here" cells.
This is what I have tried to far:
Sub Macro1()
'
' Macro1 Macro
'
Dim sumhere As Range
Dim startingpoint As Range
Dim endingpoint As Range
'
Range("C17").Select
Selection.End(xlDown).Select
If ActiveCell = "avg" Then
ActiveCell.Offset(rowoffset:=0, columnoffset:=2).Select
Set sumhere = ActiveCell
Set startingpoint = ActiveCell.Offset(rowoffset:=-1, columnoffset:=0)
Selection.End(xlUp).Select
If (ActiveCell.Value) = "Sum here" Then
Set endingpoint = ActiveCell.Offset(rowoffset:=1, columnoffset:=0)
sumhere.Formula = "=sum(range(startingpoint:endingpoint)"
Else
Selection.End(xlUp).Select
If (ActiveCell.Value) = "Sum here" Then
Set endingpoint = ActiveCell.Offset(rowoffset:=1, columnoffset:=0)
sumhere.Formula = "=Sum(Range(startingpoint.adress:endingpoint.adress))"
Else: End If
End If
End If
End Sub
Additionally, as you can see, I do not know, how to define a range using variables. My original idea was to combine this code with some kind of "do while" or/and "for i= 1 to x" and "next i". But I can't see how to combine it.
Using formula only, and providing that column A only has avg (or any text) on each subtotal row.
I've given two versions of the formula - the volatile version (updates everytime you change anything on the spreadsheet), and the non-volatile version (only updates if it needs to).
The formula should be entered on row 6 - change the $E6 to which ever row you need.
(volatile)
=SUM(OFFSET($E6,IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)-ROW()+1,,ROW()-1-IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)))
(non volatile):
=SUM(INDEX($E:$E,IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)+1):INDEX($E:$E,ROW()-1))
or if you don't mind using a helper column:
In cell B6:
=IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)
In E6: (volatile)
=SUM(OFFSET($E6,$B6-ROW()+1,,ROW()-1-$B6))
or (non volatile):
=SUM(INDEX($E:$E,$B6):INDEX($E:$E,ROW()-1))
Edit:
Thought I'd add a UDF to calculate it to if you're after VBA.
Use the function =AddSubTotal() in the rows you want the sub total to be shown in, or use =AddSubTotal("pop",6) to sum everything in column F (col 6) using "pop" rather than "avg".
Public Function AddSubTotal(Optional Delim As String = "avg", Optional ColNumber = 5) As Double
Dim rCaller As Range
Dim rPrevious As Range
Dim rSumRange As Range
Set rCaller = Application.Caller
With rCaller.Parent
Set rPrevious = .Range(.Cells(1, 1), .Cells(rCaller.Row - 1, 1)).Find(Delim, , , , , xlPrevious)
If Not rPrevious Is Nothing Then
Set rSumRange = rPrevious.Offset(1, ColNumber - 1).Resize(rCaller.Row - rPrevious.Row - 1)
Else
Set rSumRange = .Range(.Cells(1, ColNumber), .Cells(rCaller.Row - 1, ColNumber))
End If
End With
AddSubTotal = WorksheetFunction.Sum(rSumRange)
End Function
The following VBA routine assumes that
your data is in Columns C:E
Nothing else relevant (nothing numeric) in that range
Your "key word" where you want to show the sum is avg
avg (the key word) is hard-coded in the macro
You could easily modify this routine to also perform an average of those values, and put those results, for example, in Column D
Any of the above are easily modified
Option Explicit
Sub TotalSubRanges()
Dim vSrc As Variant, rSrc As Range
Dim dAdd As Double
Dim I As Long
Const sKey As String = "avg"
Set rSrc = Range(Cells(1, "C"), Cells(Rows.Count, "C").End(xlUp)).Resize(columnsize:=3)
vSrc = rSrc
'Do the "work" in a VBA array, as this will
' execute much faster than working directly
' on the worksheet
For I = 1 To UBound(vSrc, 1)
If vSrc(I, 1) = sKey Then
vSrc(I, 3) = dAdd
dAdd = 0
Else
If IsNumeric(vSrc(I, 3)) Then dAdd = dAdd + vSrc(I, 3)
End If
Next I
'write the results back to the worksheet
' and conditionally format the "sum" cells
With rSrc
.EntireColumn.Clear
.Value = vSrc
.Columns(3).AutoFit
.EntireColumn.ColumnWidth = .Columns(3).ColumnWidth
.FormatConditions.Delete
.FormatConditions.Add _
Type:=xlExpression, _
Formula1:="=" & .Item(1, 1).Address(False, True) & "=""" & sKey & """"
With .FormatConditions(1)
.Interior.ColorIndex = 6
End With
End With
End Sub
Surely you just need something like:
Sub sums()
Dim i As Integer, j As Integer, k As Integer
j = Range("C1048576").End(xlUp).Row
k = 1
For i = 1 To j
If Range("C" & i).Value <> "" Then
Range("E" & i).Value = "=Sum(E" & k & ":E" & i - 1 & ")"
k = i + 1
End If
Next i
End Sub
Change:
Dim startingpoint As Range
Dim endingpoint As Range
To:
Dim startingpoint As Variant
Dim endingpoint As Variant
As the startingpoint and endingpoint is used in a formula, you cant define them as a Range.
So I'm hoping for some help to automate a process that will otherwise involve copying and editing some 10,000 rows.
This is stuff relating to location data. Essentially, there are tons of these Master Rows but they do not have individual rows for Unit Numbers. I am hoping to get something to expand these into individual Unit Number rows based on what is in Column N. Column N is intended to follow a strict format of being a comma-seperated single cell list for each row.
Below is an example from Sheet 1 of what each row will have and needs to be expanded upon. Note that Column N is green and follows a consistent formatting and this will be the determinant for how many times these rows will each be expanded upon.
Below is Sheet 2 and what I want the VBA to create from Sheet 1. You can see that each row has been expanded based on the contents of Column N from Sheet 1.
Like I said, it is expected that this will involve some several thousand rows to create.
Option Explicit
Sub Tester()
Dim sht1, sht2, rwSrc As Range, rwDest As Range, v, arr, n
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
sht2.Range("A2:M2").Resize(3, 13).Value = sht1.Range("A2:M2").Value
Set rwDest = sht2.Range("A2:M2") 'destination start row
Set rwSrc = sht1.Range("A2:M2") 'source row
Do While Application.CountA(rwSrc) > 0
v = rwSrc.EntireRow.Cells(1, "N").Value 'list of values
If InStr(v, ",") > 0 Then
'list of values: split and count
arr = Split(v, ",")
n = UBound(arr) + 1
Else
'one or no value
arr = Array(v)
n = 1
End If
'duplicate source row as required
rwDest.Resize(n, 13).Value = rwSrc.Value
'copy over the unit values
rwDest.Cells(1, "G").Resize(n, 1).Value = Application.Transpose(arr)
'offset to next destination row
Set rwDest = rwDest.Offset(n, 0)
'next source row
Set rwSrc = rwSrc.Offset(1, 0)
Loop
End Sub
This does the work in same sheet... Pls copy the value to "Sheet2" before executing this. Not sure about efficiency though.
Public Sub Test()
Dim lr As Long ' To store the last row of the data range
Dim counter As Long
Dim Str As String ' To store the string in column N
lr = Range("N65536").End(xlUp).Row 'Getting the last row of the data
For i = lr To 2 Step -1
Str = Range("N" & i).Value ' Getting the value from Column N
counter = 1
For Each s In Split(Str, ",")
If counter > 1 Then
Range("A" & (i + counter - 1)).EntireRow.Insert ' Inserting rows for each value in column N
Range("G" & (i + counter - 1)).Formula = s ' Updating the value in Column G
Else
Range("G" & i).Formula = s ' No need to insert a new row for first value
End If
counter = counter + 1
Next s
Next i
lr = Range("G65536").End(xlUp).Row
' Pulling down other values from the first value row other rows
Range("A1:N" & lr).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
' Pasting the data as Values to avoid future formula issues.
Range("A1:N" & lr).Copy
Range("A1:N" & lr).PasteSpecial xlPasteValues
MsgBox "Done"
End Sub