There’s one step that’s stuck, to update the stock number (column "D") in the database_ gudang (stock in the database_ gudang is added to the amount of receipt (column "K") from form_penerimaan)
The update is based on the name of the item (nama barang), so if the name of the item (column "C") in the form_penerimaan is the same as the name of the item (column "B") in the database_ gudang, the stock in database_ gudang will be updated.
but there’s a problem, which is updated only in rows 2,9,10 (yellow cell). A row of 3,4,5 should also be updated.
Thank you very much for your help.
Regards.
Sub Module1()
s = 10
OT1 = Sheets("Database_Gudang").Cells(Rows.Count, "D").End(xlUp).Row
For j = 2 To OT1
NB1 = Sheets("Database_Gudang").Cells(j, "B").Value
Sheets("Form_Penerimaan").Activate
If Cells(s, "C").Value = NB1 And Cells(s, "C").Value <> "" Then
Sheets("Form_Penerimaan").Cells(s, "Q").Copy
Sheets("Database_Gudang").Activate
Sheets("Database_Gudang").Cells(j, "G").Select
Selection.PasteSpecial Paste:=xlPasteValues
s = s + 1
End If
Next j
End Sub
Hi and Welcome to stackoverflow :)
Avoid the use of .Select and .Activate. Directly work with variables and objects. You may want to see How to avoid using Select in Excel VBA
You are facing that issue because you are not looping through the cells of the 2nd sheet.
Is this what you are trying? (UNTESTED)
I have commented the code so you may not have a problem in understanding it. If you do then share the exact error message and we will take it from there.
Sub Sample()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim i As Long, j As Long
Dim wsThisLRow As Long, wsThatLRow As Long
'~~> Set your worksheets
Set wsThis = ThisWorkbook.Sheets("Database_Gudang")
Set wsThat = ThisWorkbook.Sheets("Form_Penerimaan")
'~~> Find relevant last row in both sheets
wsThisLRow = wsThis.Range("D" & wsThis.Rows.Count).End(xlUp).Row
wsThatLRow = wsThat.Range("C" & wsThat.Rows.Count).End(xlUp).Row
With wsThis
'~~> Loop through cell in Database_Gudang
For i = 2 To wsThisLRow
'~~> Loop through cell in Form_Penerimaan
For j = 10 To wsThatLRow
'~~> Compare values and get values across if applicable
If .Range("B" & i).Value = wsThat.Range("C" & j).Value Then
.Range("G" & i).Value = wsThat.Range("Q" & j).Value
Exit For
End If
Next j
Next i
End With
End Sub
Related
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.
The purpose of this macro is copy one cell value (from a long list) to another cell located in a different sheet.
here's my code:
Sub journalben()
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
Set Rng = Range("G2:G1048576")
For Each cell In Rng
'test if cell is empty
If cell.Value <> "" Then
finaljnl.Range("L4").Value = rawben.Range("G5").Value
finaljnl.Range("K4").Value = rawben.Range("L5").Value
End If
Next
End Sub
With the help of the image, I will explain what I'm trying to achieve:
From Sheet1 ("BEN") there's a list sitting in columns G and L.
I will copy the cell G5 from Sheet1 and paste it in Sheet2 ("JNL_BEN") Range K4.
Next is I will copy the cell L5 from Sheet1 and paste it in Sheet2 ("JNL_BEN") Range L4.
Copy the next in line and do the same process just like No.2 and 3 but this time, it will adjust 1 row below.
Copy the whole list. That means up to the bottom. The list is dynamic, sometimes it will go for 5,000 rows.
For some reasons, copying the entire column is not an option to this macro due to requirement that cells from sheet1 MUST be pasted or placed in Sheet2 from left to right (or horizontally).
I hope you could spare some time to help me. My code didn't work, I guess the implementation of FOR EACH is not correct. I'm not sure if FOR EACH is the best code to use.
I appreciate anyone's help on this. Thank you very much! May the force be with you.
Try this:
Sub journalben()
Dim i As Long, lastRow As Long
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
lastRow = rawben.Cells(Rows.Count, "G").End(xlUp).Row
For i = 5 To lastRow
'test if cell is empty
If rawben.Range("G" & i).Value <> "" Then
finaljnl.Range("K" & i - 1).Value = rawben.Range("G" & i).Value
finaljnl.Range("L" & i - 1).Value = rawben.Range("L" & i).Value
End If
Next i
End Sub
I am starting FOR from 5 as the data in your image starts from cell G5 (not considering the header).
It'll be easier to use a numeric variable for this :
Sub journalben()
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
Set Rng = rawben.Range("G4:G1048576")
For i = Rng.Cells(1,1).Row to Rng.Cells(1,1).End(xlDown).Row
'test if cell is empty
If rawben.Range("G" & i).Value <> vbNullString Then
finaljnl.Range("L" & i - 1).Value = rawben.Range("G" & i).Value
finaljnl.Range("K" & i - 1).Value = rawben.Range("L" & i).Value
End If
Next i
End Sub
You should use a simple for loop. It is easier to work with.
Also, to have it dynamic and to go to the last cell in the range, use the SpecialCells method.
And your range needs to be set correctly from row 5.
Here is the code:
Sub journalben()
Set rawben = Sheets("BEN")
Set finaljnl = Sheets("JNL_BEN")
Set Rng = Range("G5:G1048576")
For i = Rng.Cells(1,1).Row to Rng.SpecialCells(xlCellTypeLastCell).Row
If rawben.Range("G" & i).Value <> vbNullString Then
finaljnl.Range("L" & CStr(i - 1)).Value = rawben.Range("G" & CStr(i)).Value
finaljnl.Range("K" & CStr(i - 1)).Value = rawben.Range("L" & CStr(i)).Value
End If
Next i
End Sub
I'm trying to build a new VBA function for Excel. I've got a book of sheets with a front page that always loads first, on this page I've got a combo box that lists all the other sheets in the book and a nice extract button that will pull out the chosen sheet to a new book. (Thanks to those here who helped with that). Now I need a new function that will use the same combo box, but instead only extract a small subset of the chosen sheet.
Unfortunately, that subset isn't on the same rows for every sheet, nor is the number of rows the same (so one sheet, the subset might be 10 rows, on another it might be 12, on another it might be 20, etc etc etc).
On the plus side, there are merged rows (from column A to G) at the start and end of each subset - with specific text, which could be used to search for.
After some back and forth, I've got a better bit of code that I think is almost working:
Sub ZCPS_Extract()
Dim StartRow
Dim EndRow
Dim Zws As Worksheet
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
StartRow = 1
EndRow = 1
'sets site details into the header of the ZCPS checksheet
Worksheets(Sheet1.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet1.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet1.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Set Zws = Sheets(Sheet1.CmbSheet.Value)
'selects ZCPS block from select estate sheet
StartRow = (Zws.Cells.Find("**** ZCPS Installation").Row) + 1
EndRow = (Zws.Cells.Find("**** Aztec Hotfixes").Row) - 1
'copy above block and paste into Z-MISC starting at row 5
Worksheets(Sheet1.CmbSheet.Value).Range(Cells(StartRow, 1), Cells(EndRow, 7)).Copy Worksheets("Z-MISC").Range("A5")
With ActiveWorkbook.Sheets("Z-MISC")
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& ActiveWorkbook.Sheets("Z-MISC").Cells(3, 2).Text _
& " ZCPS CheckSheet " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub
It's error on the line for copying, I'm getting a runtime error of "Application-defined or object-defined error" which to my limited knowledge isn't helping me. Any assistance/pointers/suggestions are welcomed.
Sub ismerged()
Dim start As Integer, finish As Integer
For i = 1 To Range("A655").End(3).Row + 1
If Cells(i, "A").MergeCells = True Then
start = i
Exit For
End If
Next
For i = start To Range("A655").End(3).Row + 1
If Cells(i, "A").MergeCells = True Then
finish = i
End If
Next
MsgBox start
MsgBox finish
End Sub
Then I guess you can select your data as you wish.
I'm not sure about the way you reference your sheet. I will assume 'comboboxvalue' contains the name or the number of the sheet you are selecting. Your code should be something like the following.
Sub Z_Extract()
Dim StartRow
Dim EndRow
Dim ws As Worksheet
Set ws = Sheets(comboboxvalue)
StartRow = ws.Cells.Find("**** ZC").Row
EndRow = ws.Cells.Find("****").Row
'Im assuming you have values up to column G
ws.Range(ws.Cells(StartRow, 1), Cells(EndRow, 7)).Copy
'Now that you have the correct Range selected you can copy it to your new workbook
'SelectedRange.Copy Etc.....
'Cleanup
Set ws = Nothing
End Sub
Got it working.
Set Zws = Sheets(Sheet1.CmbSheet.Value)
'selects ZCPS block from selected estate sheet
StartRow = (Zws.Cells.Find("**** ZCPS Installation").Row)
EndRow = (Zws.Cells.Find("**** Aztec Hotfixes").Row) - 1
'copy above block and paste into Z-MISC starting at row 10
Sheets(Sheet1.CmbSheet.Value).Activate
ActiveSheet.Range(Cells(StartRow, 1), Cells(EndRow, 7)).Select
Selection.Copy
Sheets("Z-MISC").Select
Range("A10").Select
ActiveSheet.Paste
I've got the following code which gets the word dividend from a column and then takes the whole row and copy pastes it to a new sheet.
Sub SortActions()
Dim i&, k&, s$, v, r As Range, ws As Worksheet
Set r = [index(a:a,match("###start",a:a,),):index(a:a,match("###end",a:a,),)].Offset(, 6)
k = r.Row - 1
v = r
For i = 1 To UBound(v)
If LCase$(v(i, 1)) = "dividend" Then
s = s & ", " & i + k & ":" & i + k
End If
Next
s = Mid$(s, 3)
If Len(s) Then
Set ws = ActiveSheet
With Sheets.Add(, ws)
ws.Range(s).Copy .[a1]
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("20140701_corporate_action_servi").Select
Rows("2:2").Select
Selection.Copy2
Range("C32").Select
Sheets("Sheet11").Select
ActiveSheet.Paste
End With
End If
End Sub
Is there a way to make this dynamic. So if I want to search for more than word. For example if I have several rows with dividends and special dividends -> it would take all rows of dividends and all rows of special dividends and put them in separate sheets. I have tried ti with recording a macro it doesn't work as the words can differ. Maybe getting the content into a list would work. Please assist . Thanks
As suggested by #Macro Man , I am submitting images of an example sheet and sheet after filter with a simple macro for filtering one field. Please all credit to #Macro Man, it is for illustration in a simple way.
Simple code as follows.
Sub Filter1Field()
With Sheet1
.AutoFilterMode = False
With .Range("A1:H13")
.AutoFilter
.AutoFilter Field:=5, Criteria1:="Dividend"
End With
End With
End Sub
*****UPDATE*******
If your other criteria such as "Sp. Dividend" is other field but on the same row as shown in the image appended and you wish to copy to other sheet you can use the code given below. Another image shows results obtained on sheet2. You can adopt the code to your requrements.
You can use this code:
Sub Test2()
Dim LastRow As Long
Sheets("Sheet2").UsedRange.Offset(0).ClearContents
With Worksheets("Sheet1")
.Range("A1:H13").AutoFilter
.Range("A1:H13").AutoFilter field:=5, Criteria1:="Dividend"
.Range("A1:H13").AutoFilter field:=6, Criteria1:="=Sp. Dividend"
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Destination:=Sheets("Sheet2").Range("A1")
End With
End Sub
I'm very new to VBA, and I'm trying to move particular items within a column to another sheet for a report.
This is my Macro:
Sub DoIHaveaPRDesignation()
Dim rng As Range
Dim i, Lastrow
Dim splitValues() As String
Lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A1:I500").ClearContents
Sheets("Sheet2").Cells(1, 1).Value = "Pair"
Sheets("Sheet2").Cells(1, 2).Value = "Commit"
Sheets("Sheet2").Cells(1, 3).Value = "CKID"
Sheets("Sheet2").Cells(1, 4).Value = "Status"
Sheets("Sheet2").Cells(1, 5).Value = "Terminal"
Sheets("Sheet2").Cells(1, 6).Value = "Address"
Set rng = ActiveCell
Dim moveValue As String
Do While rng.Value <> Empty
If InStr(rng.Value, " pr") = 0 Then
MsgBox "Haven't found Pair "
Else
MsgBox rng.Value
End If
Set rng = rng.Offset(1)
rng.Select
Loop
MsgBox "Done!"
End Sub
This is one instance of the data (Column A, Rows 1 - 6):
pr 1 stat RCT commit stat P
sys: type 73RMD no 1 slot: 1 lt: field stat DZ7K co stat NREQ
ckid NONE lp stat RCT 11-30-13 bp/clr 601 tea 1975 W SOUTHPORT RD
type FIXED tec IPLPINPL fld side capr 1975W:279
dist tea 7250 WINSLET BLVD type FIXED addr: 7250 WINSLET BLVD
UNIT 2D serv tea 7250 WINSLET BLVD type FIXED
The code finds the occurance of "pr", but I cannot seem to fidgure out how to pick it up and move it. I need to repeat this for the 6 columns I formatted on sheet 2, but if I get help with the first I can figure out the rest.
Thanks!
This answer discusses features of your existing code that are not recommended and introduces techniques that I believe are relevant to your requirement.
Issue 1
Dim i, Lastrow
The above declares i and Lastrow as variants which can hold anything. For example, the following code is valid:
i = "A"
i = 5
Variants can be very useful but they are slower to access than properly typed variables. I recommend:
Dim i As Long, Lastrow As Long
Issue 2
Sheets("Sheet2").Range("A1:I500").ClearContents
I assume Range("A1:I500") is intended to be larger than the area that was used on a previous run of the macro.
I would write Sheets("Sheet2").Cells.ClearContents and let Excel worry about the range used last time.
Note that ClearContents, as the name implies, only clears the contents. Clear will also clear any formatting. Sheets("Sheet2").Cells.EntireRow.Delete will delete contents and formatting and restore the column widths to their default. However, ClearContents may be adequate for your needs.
Issue 3
Sheets("Sheet2").Range("A1:I500").ClearContents
Sheets("Sheet2").Cells(1, 1).Value = "Pair"
Sheets("Sheet2").Cells(1, 2).Value = "Commit"
Sheets("Sheet2").Cells(1, 3).Value = "CKID"
Sheets("Sheet2").Cells(1, 4).Value = "Status"
Sheets("Sheet2").Cells(1, 5).Value = "Terminal"
Sheets("Sheet2").Cells(1, 6).Value = "Address"
Use of the With statement generally makes your code clearer and faster:
With Sheets("Sheet2")
.Range("A1:I500").ClearContents
.Cells(1, 1).Value = "Pair"
.Cells(1, 2).Value = "Commit"
With .Cells(1, 3)
.Value = "CKID"
.Interior.Color = RGB(0, 240, 240)
End With
.Cells(1, 4).Value = "Status"
.Cells(1, 5).Value = "Terminal"
.Cells(1, 6).Value = "Address"
End With
I have coloured cell C1 to show that With statements can be nested.
Issue 4
Set rng = ActiveCell
As I understand it, the source data is in worksheet Sheet1 and starts at cell A1. The above means your code will start at whatever cell in whatever worksheet the user has positioned the cursor. If there is a fixed starting point then set that in your code. If you do want the user to be able to control the starting point consider:
If ActiveCell.Worksheet.Name <> "Sheet1" Then
Call MsgBox("Please position the cursor to the desired starting " & _
"point in worksheet ""Sheet1""", vbOKOnly)
Exit Sub
End If
Issue 5
Set rng = ActiveCell
:
Set rng = rng.Offset(1)
rng.Select
Accessing a selected cell is much slower than accessing the cell using VBA addressing. I have also seen programmers get hopeless confused about the current location of the cursor when using Offset. You have used VBA addressing to set the header row and I have used it in my sample code below.
Issue 6
Lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Do While rng.Value <> Empty
You set Lastrow to the number of the last row with a value but your loop moves down the column until it hits an empty cell. If there are no empty rows within the body of the data, this will give the same result. However I suggest you decide which approach is appropriate.
I would avoid the use of Empty. See What is the difference between =Empty and IsEmpty() in VBA (Excel)?.
Sample code
The following code includes the parts relevant to your question. I move the contents of cells containing " pr" to column 1 of worksheet "Sheet2" which is what you seem to be asking. However, if you wanted to split cells containing " pr" and copy selected parts to Sheet2, I would have handled your requirement in a different way. I can add a further section to this answer if you clarify what you seek.
Option Explicit
Sub MovePRRows()
Dim Rng As Range
Dim RowSheet1Crnt As Long
Dim RowSheet1Last As Long
Dim RowSheet2Crnt As Long
Dim WSht2 As Worksheet
Set WSht2 = Worksheets("Sheet2")
WSht2.Cells.EntireRow.Delete
RowSheet2Crnt = 2
With Worksheets("Sheet1")
RowSheet1Last = .Cells(Rows.Count, "A").End(xlUp).Row
For RowSheet1Crnt = 1 To RowSheet1Last
Set Rng = .Cells(RowSheet1Crnt, 1)
If Rng.Value <> "" Then
If InStr(1, Rng.Value, " pr") <> 0 Then
Rng.Copy Destination:=WSht2.Cells(RowSheet2Crnt, 1)
RowSheet2Crnt = RowSheet2Crnt + 1
End If
End If
Next
End With
End Sub