How to do Excel looping using VBA - excel

I am working on a tool to build a stored procedure based on the available prices getting directly from vendor. As per the attached snap, I paste all the rics (identifier) under column I and put the number of days in cell B2 (let's say I am looking for last 300 days of historical prices for STIM.OQ, VOD.L (vodafone) and AAPL.OQ (Apple Inc).
Currently this tool only fetches the prices for a single ric based on the cell value A2, I wanted to put this in a loop so that whatever rics I paste in column I go through that loop and the code should copy the stored procedure from column F and append it to a new single sheet for each of the rics.
Note: the stored procedure takes the value from cell B8, D8 and E8

Use ws.Cells(Rows.Count, "I").End(xlUp).Row to find the last row and then loop through starting at row 2.
Option Explicit
Sub CreateProcs()
Dim wb As Workbook, ws As Worksheet, wsRic As Worksheet
Dim iLastRow As Long, r As Long, n As Long, i As Integer
Dim ric As String
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' as appropriate
n = ws.Range("B2").Value ' days
' loop through rics in col I
iLastRow = ws.Cells(Rows.Count, "I").End(xlUp).Row
For r = 2 To iLastRow
ric = ws.Cells(r, "I")
ws.Range("A2").Value2 = ric
' create sheet
Set wsRic = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
wsRic.Name = ric
' copy data
wsRic.Range("A1:A" & n).Value2 = ws.Range("F8").Resize(n).Value2
i = i + 1
Next
MsgBox i & " sheets created", vbInformation
End Sub

Related

VBA Add rows based on how many times a criteria is met

I am quite new to VBA so my question may sound silly to some of you.
I have a problem with my code. I am trying to check between 2 sheets(1st: test and 2nd: test data. In the code I am using the code name of the sheets) how may times a criteria/my product is met and based on that number to add that many rows beneath the SKU/product.
What I want to do is, if for my first product/SKU I have stock in 5 different locations, I want to add 5 rows in the first sheet and to see the qty in column D and the location in column E.
TestData tab
The reason why I need to list the quantity in different cells is that the stock is in different locations, so I can not just add in to one cell.
I am also adding screen shots of how my two sheets look like.
I have not add the loop to find the location yet, but I want to understand how to add the rows first.
Sub test()
Dim myrange As Range, testrange As Range, cell As Range, result As Range
Dim i As Long, testlastrow As Long, lastrow As Long
Dim helprng As Range
lastrow = TESTTAB.Range("a" & Rows.Count).End(xlUp).row
testlastrow = TDATA.Range("a" & Rows.Count).End(xlUp).row
Set testrange = TDATA.Range("a2:c" & testlastrow)
Set myrange = TESTTAB.Range("b2:b" & lastrow)
Set result = TESTTAB.Range("d2:e" & testlastrow)
Set helprng = TESTTAB.Range("f2:f" & lastrow)
For Each cell In myrange
For i = 1 To lastrow
If cell.Cells(i, 1) = testrange.Cells(i, 1) Then
result.Cells(i, 1) = testrange.Cells(i, 2)
End If
Next i
Next cell
End Sub
Here is the raw structure you were asking for.
Sub test()
' 011
Dim Rng As Range
Dim Tmp As Variant
Dim Radd As Long ' number of rows to add
Dim R As Long ' row counter
With Tdata
' Range, Cells and Rows Count, all in the same sheet
' exclude caption row(s)
Set Rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
Application.ScreenUpdating = False ' speed up the process
With TestTab
' end the loop in row 2 because row 1 might contain captions
' loop bottom to top because row numbers will change
' below the current row as you insert rwos
' column 1 = "A"
For R = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
Tmp = .Cells(R, 1).Value
Radd = Application.CountIf(Rng, Tmp)
If Radd > 1 Then
.Range(.Rows(R + 1), .Rows(R + Radd)).Insert
.Cells(R + 1, 1).Value = Radd ' for testing purposes
End If
Next R
End With
Application.ScreenUpdating = True ' now you look
End Sub
As our Evil Blue Monkey has suggested, inserting blank rows and then populating them may not be the most efficient way. You can copy a row and then click Insert to insert the copied data into a new row. Get the syntax from the Macro recorder if it's of interest. It works with the Range object the same way.

Copy every n of cells every n of columns and paste in a new row, for every row

In the above example, I'd like to start in F2, and copy F2,G2 and H2, then paste those values in a new row.I'd like to continue to do that until the last column at the end of the row.I would also be ok if I started in C2 and had to paste in a new sheet. I'd like to continue doing this until the last row is empty.
I've found this, but it only copies every 3rd cell, not a range:
Sub CopyNthData()
Dim i As Long, icount As Long
Dim ilastrow As Long
Dim wsFrom As Worksheet, wsTo As Worksheet
Set wsFrom = Sheets("Sheet2")
Set wsTo = Sheets("Sheet1")
ilastrow = wsFrom.Range("B100000").End(xlUp).Row
icount = 1
For i = 1 To ilastrow Step 3
wsTo.Range("B" & icount) = wsFrom.Range("B" & i)
icount = icount + 1
Next i
End Sub
I assume the best way to do this is through VBA, but I'm a bit of a novice in VBA. Any suggestions would be appreciated.
If I understand your comment correctly, you just want to copy a larger range?
You can do that similar to:
stepCt = 3
lr = stepCt-1
For i = 1 To ilastrow Step stepCt
With wsTo
.Range(.Cells(icount,2),.Cells(icount+lr,2)) = wsFrom.Range(wsFrom.Cells(i,2),wsFrom.Cells(i+lr,2))
End With
icount = icount + stepCt 'Accounts for multiple ROWS
Next i
Can do similar to multiple columns, where instead of adding lr (last row) to the row argument of Cells() you can add to the column argument of Cells(). The use of stepCt wouldn't be necessary in that case.
Edit1:
Changing to show columns, not rows, as the original question changed from asking for copying F2, F3, & F4 to F2, G2, & H2.
For i = 1 To ilastrow
With wsTo
.Range(.Cells(icount,6),.Cells(icount,8)).Value = wsFrom.Range(wsFrom.Cells(i,6),wsFrom.Cells(i,8)).Value
End With
icount = icount + 1
Next i
I'm not sure this is what you are looking for, but this will paste all data in a range starting from F2 into a new sheet starting in C2.
Sub CopyNthData1()
Dim Source As Range
Set Source = Worksheets("Sheet1").Range(("F2"), Range("F2").End(xlDown).End(xlToRight))
Source.Copy
Dim DestRange As Range
Set DestRange = Worksheets("Sheet2").Range("C2")
DestRange.PasteSpecial xlPasteAll
End Sub

Finding the occurrence across multiple sheets but with a twist

I wanted to find the number of sick leave of the workers per month. I know that can be achieved easily with =Ifs (), but as you can see from this screenshot:
the sheets may contain the data of other months (late December and early February in this case). There are 12 sheets in total, each contains one month of the year.
I want to write a function that can count the numbers of holidays given by "休息" for each month for each person.
The difficulty is that:
The roaster changes every month and cell position of each person changes, the other problem is:
As mentioned above, each sheet may contain data of other months, which implies the function has to refer to other sheets to count these leaves as well.
Can this be achieved with excel intrinsic functions or should this be done with VBA?
It is real difficult and lot of assumption, to try and understand the problem in unknown language and scanty details. However the solution worked out based of a number of assumption and hope to offer only broad outline to be modified as real time solution according to actual layout of the working file
Assumptions:
Names are in column B
Names start at row 11
For trial only rows up to 35 are used
Days span from column D to AF (Approx)
Column AL is free and used for Countif formula
For solution with excel formulas
Populate column AL of all the monthly sheets with formula
=COUNTIF(D11:AE11,"休息")
In a blank Sheet named “Main” populate column B with list of all the names (may be starting from row 11)
Now Column C representing Month1 may be added with formula
=IF(ISNA(MATCH($B11,Sheet1!$B$11:$B$35,0)), "",INDEX(Sheet1!$AL$11:$AL$35,MATCH($B11,Sheet1!$B$11:$B$35,0),1))
Similarly Column D representing Month1 may be added with formula
=IF(ISNA(MATCH($B12,Sheet2!$B$11:$B$35,0)), "",INDEX(Sheet2!$AL$11:$AL$35,MATCH($B12,Sheet2!$B$11:$B$35,0),1))
And similarly add formula to all the 12 columns pointing towards 12 sheets in the workbook and the create a summation in next blank column
Result Sheet Layout - Main and Month sheets Layout
VBA solution
Add one blank sheet Named “MainVBA” containing list of all the names in the column B starting from row 11 as done in sheet named “Main”. Alternatively this employee list could be created by using dictionary object and collecting all unique names (case sensitive) from all the monthly sheets. For using this code please add reference to “Microsoft Scripting runtime”. (VBA window – Tools – Reference)
Code:
Sub MakeList()
Dim MnWs As Worksheet, Ws As Worksheet
Dim Srw As Long, S1rw As Long
Dim Erw As Long, E1rw As Long
Dim Xname As String
Dim TRw As Long
Dim Cnt As Long
Dim Dict As Dictionary
Set MnWs = ThisWorkbook.Sheets("MainVBA")
Srw = 11 'Starting Row in Result sheet Named "MainVBA"
Erw = MnWs.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Result sheet Named "MainVBA"
MnWs.Range("B" & Srw & ":B" & Erw).ClearContents ' Delete last row
Set Dict = New Dictionary
'Get Names from monthly sheets
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "MainVBA" And Ws.Name <> "Main" Then ' Consider all sheets Other than specified two having sick leave data
S1rw = 11
E1rw = Ws.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Month sheet
For TRw = S1rw To E1rw
Xname = Ws.Cells(TRw, "B").Value
If Dict.Exists(Xname) = False Then
'Debug.Print Ws.Name, TRw, Xname
Dict.Add Xname, 1
End If
Next
End If
Next Ws
'create list in Sheet "MainVBA" Column B from dictionary
For Cnt = 0 To Dict.Count - 1
MnWs.Cells(Cnt + 11, "B").Value = Dict.Keys(Cnt)
Next
Set Dict = Nothing
End Sub
Code for calculating sick leave count month wise. I used Range B1 to hold the string "休息" (as I refrained to tweak the regional settings etc) , it may be used directly in your VBA module.
Option Explicit
Sub test()
Dim MnWs As Worksheet, Ws As Worksheet
Dim Srw As Long, S1rw As Long, Scol As Long
Dim Erw As Long, E1rw As Long, Ecol As Long
Dim Rw As Long, Col As Long, Xname As String, ChineseStr As String
Dim TRw As Long, XRw As Long, Have As Boolean
Dim Rng As Range, Cnt As Long
Set MnWs = ThisWorkbook.Sheets("MainVBA")
ChineseStr = MnWs.Range("B1").Value 'May use string directly with quotes
Srw = 11 'Starting Row in Result sheet Named "MainVBA"
Erw = MnWs.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Result sheet Named "MainVBA"
Scol = 3 'Starting Col Month1 in Result sheet Named "MainVBA"
Ecol = 3 + 11 'End Col Month12 in Result sheet Named "MainVBA"
For Rw = Srw To Erw
Xname = MnWs.Cells(Rw, "B").Value
Col = Scol
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "MainVBA" And Ws.Name <> "Main" Then ' Consider all sheets Other thah specified two having Sick leave data
S1rw = 11
E1rw = Ws.Cells(Rows.Count, "B").End(xlUp).Row 'Last Row in Month sheet
XRw = 0
For TRw = S1rw To E1rw
If Ws.Cells(TRw, "B").Value = Xname Then
XRw = TRw
Exit For
End If
Next
Cnt = 0
If XRw > 0 Then
'Debug.Print Xname, Ws.Name, TRw
Set Rng = Ws.Range("D" & XRw & ":AF" & XRw) ' Col D to AF condsidered having sick leave data
Cnt = Application.WorksheetFunction.CountIf(Rng, ChineseStr) 'sum of month sick leave
End If
MnWs.Cells(Rw, Col).Value = Cnt
Col = Col + 1
End If
Next Ws
Next Rw
End Sub
To make this code working, it may be required to modify all the sheets details like sheets name, row, column details etc. Feel free to feedback if code is some where near to your objective and actual scenario.

VBA copy rows to empty rows in other worksheet

I'm trying to create a macro to copy data from worksheet A to worksheet B.
Worksheet A is just filled with data without any layout.
Worksheet B has a particular layout in which the data of worksheet A should be pasted.
Worksheet B has a header in the first 10 rows, so the copying should start at row 11. Data in worksheet A start at row 2. So row2(A)=>row11(B), row3(A)=>row12(B),...
The code for this part of the problem included below.
The condition I'm struggling with is that only rows without a value in colum F in worksheet B should be used.
So par example if rows 11-61 in worksheet B have no value in column F, rows 2-52 of worksheet A should be pasted in rows 11-61 in worksheet B. If cell F62 isn't empty, that row should be skipped en the next row of worksheet A (row 52) should be pasted in row 63 in worksheet B. And so on, till the next row with data in column F.
The code so far:
Sub RO()
'
' RO Macro
'
' Sneltoets: Ctrl+Shift+S
'
Dim a As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("SO")
Set Target = ActiveWorkbook.Worksheets("RO")
j = 11 ' Start copying to row 11 in target sheet
For Each a In Source.Range("A2:A10000") ' Do 10000 rows
If a <> "" Then
Source.Rows(a.Row).Copy Target.Rows(j)
Target.Rows(j).Value = Source.Rows(a.Row).Value
j = j + 1
End If
Next a
Thanks in advance!
I usually use this piece of code to copy paste values.
its pretty quick
Public Sub Copy()
Dim Source As Worksheet
Dim SourceRow As Long
Dim SourceRange As String
Dim Target As Worksheet
Dim TargetRow As Long
Dim TargetRange As String
Dim ColumnCount As Long
Set Source = ActiveWorkbook.Worksheets("Blad1")
Set Target = ActiveWorkbook.Worksheets("Blad2")
TargetRow = 11
ColumnCount = Source.UsedRange.Columns.Count
For SourceRow = 1 To Source.UsedRange.Rows.Count
SourceRange = Range(Cells(SourceRow, 1), Cells(SourceRow, ColumnCount)).Address
While Target.Cells(TargetRow, 6).value <> ""
TargetRow = TargetRow + 1
Wend
TargetRange = Range(Cells(TargetRow, 1), Cells(TargetRow, ColumnCount)).Address
Target.Range(TargetRange).Value = Source.Range(SourceRange).Value
TargetRow = TargetRow + 1
Next
End Sub
Try using 2 separate counts, 1 to keep track of the source rows you are trying to copy, and another to keep track of the target rows you are trying to paste. then you can increment them independently depending if a row passes a criteria etc.
If you are pasting blocks have 2 sets of row counts: source start & source end, paste start & paste end. Not fancy, but allows max control and processing of exceptions etc.

How to keep a log of usage of a macro

I have a rather silly problem. I have a macro (linked to a button) which copies cells A1:A2 from one worksheet (namedFP) to another worksheet (Log). I intend to copy these 2 cells on the log sheet every time I hit the macro button. The problem I am facing right now is that when I use the button multiple times, these cells are getting copied over each other instead of using the next available row to paste the cells.
This is what I have now, and I tried changing the 'Rowcount+1' to 'RowCount+2' but that did not work. Any help is appreciated.
DHRSheet.Select
Range("A1:A2").Select
Selection.Copy
LogSheet.Select
RowCount = LogSheet.UsedRange.Rows.Count
Dim r As Integer
r = RowCount + 1
Dim infocell As Range
Set infocell = Cells(r, 1)
infocell.Select
ActiveSheet.Paste
infocell.Value = DHRSheet.Name & "$" & infocell.Value
DHRSheet.Select
ActiveWorkbook.Save
Is this what you are trying?
Sub Sample()
Dim LogSheet As Worksheet, DHRSheet As Worksheet
Dim lrow As Long
'~~> Change this as applicable
Set LogSheet = Sheets("Sheet1")
Set DHRSheet = Sheets("Sheet2")
With LogSheet
lrow = LogSheet.Range("A" & .Rows.Count).End(xlUp).Row + 1
DHRSheet.Range("A1:A2").Copy .Range("A" & lrow)
End With
End Sub
Here's a function I use that is very reliable and always returns the last row of a sheet without fail:
(possibly excessive for your simple use, but I always recommend it)
Public Function LastRowOfSheet(ByVal TestSheetNumber As Variant)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Input: Sheet index # or Sheet name
' Output: Last row of sheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim intNumberOfRowsInWorksheet As Long
intNumberOfRowsInWorksheet = Sheets(TestSheetNumber).UsedRange.Rows.Count
intNumberOfRowsInWorksheet = intNumberOfRowsInWorksheet + Sheets(TestSheetNumber).UsedRange.Row - 1
LastRowOfSheet = intNumberOfRowsInWorksheet
End Function
And I'd clean up your above code and use something like this:
Sub Move2RowsToEnd()
Dim iNextRowOfOutput As Long
Dim iRowNumber As Long
'- use the function to find the last row of the output sheet. we'll be pasting to the first row after.
iNextRowOfOutput = (LastRowOfSheet("Log") + 1)
'- you can adjust this for loop to loop through additional cells if you need to paste more than 2 rows in the future.
For iRowNumber = 1 To 2
'- for each row of input (2 total) set the value of the output sheet equal to it.
Sheets("Log").Range("A" & iNextRowOfOutput).Value = Sheets("namedFP").Range("A" & iRowNumber).Value
iNextRowOfOutput = iNextRowOfOutput + 1
Next iRowNumber
'- not sure which of these you want to save (one or both)
Sheets("namedFP").Save
Sheets("Log").Save
End Sub
Just paste the function above or below the Subroutine and let me know if you have any issues or questions regarding the 'Move2RowsToEnd' code.

Resources