Copy paste every 10 cells range *10 times to a column - excel

I want to copy & paste every 10 rows, 10 times from column A to column B and so on continuing until the end of column A.
This is an example of macro I've tried:
Sub cpydble()
Dim j As Long
Dim i As Long
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).row
For i = 1 To lRow Step 10
For j = 1 To 100 Step 10
Cells(i, 1).Resize(10).Copy Destination:=Cells(j, 2)
Next j
Next i
End Sub
I'm a beginner with VBA and hope you can help with this - thanks in advance.
This is my current result:

You could use:
For i = 1 To lRow Step 10
Range("B" & i & ":B" & i + 9).Value = Range("A1:A10").Value
Next i
Note that with the above code, the last iteration will go below the last row in column A should it not be a multiple of 10.

Starting j at 1 every time is probably what's messing stuff up. Just find the next open cell for every loop.
Sub cpydbl()
Dim i As Long, j As Long
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow Step 10
For j = 1 To 10
Cells(i, 1).Resize(10).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
Next j
Next i
Cells(1, 2).Delete xlShiftUp
End Sub
The Offset starts the copy at row 2, so I delete the empty first cell at the end to move everything up.

Fully flexibilized code
In addition to #DickKusleika 's fine code, I demonstrate a fully flexibilized approach using a data array where you can define alternative block size, number of repetitions and start row via constants.
Option Explicit ' declaration head of your code module
Sub copyBlocks()
Const SIZE& = 10, REPETITIONS& = 10, STARTROW& = 1 ' define block size, repetions and start row
Dim ws As Worksheet, i&, j&, k&, n&, v ' declare variables
Set ws = ThisWorkbook.Worksheets("MySheet") ' << change to your sheet name
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' find last row number in column A
n = ((n + SIZE) \ SIZE) * SIZE ' round up to full block size of 10 rows
ws.Range("B:B") = "" ' clear column B
k = STARTROW ' start row of 1st block series
For i = STARTROW To n Step SIZE ' if STARTROW = 1 For i=1, 11, 21, 31 ... To n
v = ws.Range("A" & i).Resize(SIZE) ' get next data block (10 rows)
For j = 1 To REPETITIONS ' write eg. 10 data blocks to column B
ws.Range("B" & (k + (j - 1) * SIZE)).Resize(SIZE) = v
Next j
k = k + SIZE * REPETITIONS ' get start row of next block series
Next i
End Sub
Notes
Declare your variables (and their types) and force yourself to do so by stating Option Explicit in the declaration head of your code module; the ampersand sign & is short for e.g. Dim i As Long. v and all not explicitly declared variables default to Variant.
Always use fully qualified range references, otherwise values default to the active sheet which might result in wrong values.
Variable n finds the last row number in column A and rounds it up to the full block size of 10 rows.
You can easily assign range values to a variant 2-dimensional array in one code line, e.g. via v = ws.Range("A1:E1234") or v = ws.Range("A1:A17").Value. Further hint Each member of this array could be addressed by row and column indices. Note that data field arrays getting values from worksheet ranges are 1-based, so the first value would be addressed as v(1,1).

Related

Assign a variable to cells to compare mutliple numbers

I have a data set where I need to compare the first number in each transect against each other.
For example, in the below data set I need to compare cells D2, D7, D12 and D17 and assign a value based on which one is the smallest number, the next smallest and so on. This will be used to assign the transect numbers in column A.
My issue is that the number of sections (in this example 4) and the number of transects (also 4 in this example) will vary. So the cells I need to compare will change.
I have written the code that calculates the number of transects, which is:
Dim tlength As Worksheet
Dim tb As Long *'tb=transect break*
Sub tlength_start_stop_coords()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("sheet1")
Set tlength = ThisWorkbook.Worksheets("transect lengths") *' assigns the sheet to a variable
for efficient coding*
tb = 0 *'counter to calculate the number of transects*
j = 2 *'counter for row*
Lastrow = Lastrow + 1 *'add a row to last row so that the last row includes a blank line.*
*'the following for loop is used to calculate the number of transects*
For i = 2 To Lastrow
If tlength.Range("D" & i) = vbNullString Then
If tlength.Range("D" & i - 1) <> vbNullString Then
tb = tb + 1 *'updates the counter*
End If
End If
Next i
tbtotal = tb *'stores the total counter in variable tbtotal for later use*
I think I may need to use a loop. But I am stuck trying to figure out how to manage the unknown number of comparisons in changing cell locations.
The desired result is in the below screenshot of the expected outcome, with results in column A. To begin with, I only need to get the number for the first row of each transect. Once I have that, I can copy using xldown.
Expected outcome:
Another possible data set and outcome expected might be:
enter image description here
with an expected outcome of:
enter image description here
Worked for me using your second set of sample data:
Sub Tester()
Dim tlength As Worksheet, i As Long, tNum As Long, v, vPrev, arr
Dim col As New Collection, e, c As Range, rng As Range
Set tlength = ThisWorkbook.Worksheets("transect lengths")
'collect all the Section 1 Latitudes and row numbers
For i = 2 To tlength.Cells(Rows.Count, "B").End(xlUp).Row
If tlength.Cells(i, "B") = 1 Then
col.Add Array(i, tlength.Cells(i, "D").Value) 'store start row and first Latitude
End If
Next i
SortCollection col, 2 'sort collection by second element in each array
tNum = 0
'loop over the sorted collection and assign the order of the transects
For Each e In col
tNum = tNum + 1
Set c = tlength.Cells(e(0), "B")
'following assumes all transects have at least 2 sections...
tlength.Range(c, c.End(xlDown)).Offset(0, -1).Value = tNum
Next e
End Sub
'Sort a collection of 0-based arrays in ascending order by the n'th element of each array
'Adapted from https://stackoverflow.com/a/3588073/478884
Sub SortCollection(col As Collection, n As Long)
Dim i As Long, j As Long, vTemp As Variant
For i = 1 To col.Count - 1 'Two loops to bubble sort
For j = i + 1 To col.Count
If col(i)(n - 1) < col(j)(n - 1) Then 'change to > for ascending sort
vTemp = col(j) 'store the lesser item
col.Remove j 'remove the lesser item
col.Add Item:=vTemp, before:=i 're-add the lesser item before the greater Item
End If
Next j
Next i
End Sub

Excel Vba how to find row's minimum value in for loop

I am using dijkstra algorithm for VRP , so it works like this
i am giving an random input between node numbers (1,2,3,..) and after that input it takes it as i and starting to searching for minimum value in i. row and finding the minimum value at j. column so next step j becomes my next row and i am trying to iterate as like that
so i need to find minimum value of row's in for loop i tried to giving
application.worksheet.function.min(range)
For i = Sheets("sayfa1").Cells(15, 1) To Sheets("sayfa1").Cells(15, 1) + 1
For j = i + 1 To 11
if cell(i,j) = application.WorksheetFunction.Min(range of row) then
cell.clearcontents
end if
i = j
nextj
but range always changing by row so it doesn't work
It is not very clear to me what you need to determine exactly. As far as I have understood, I have quickly written a macro for your question. Hope it solves your problem or at least helps you to get to the solution. You could try something like this:
Sub Min_values_loop()
Dim ws1 As Worksheet
Dim FirstCol As Long, LastCol As Long, FirstRow As Long, LastRow, MinValue As Long
'set sheet name
Set ws1 = Worksheets("sayfa1")
'set your frist and last column and row numbers here
FirstCol = 1
LastCol = 3
FirstRow = 1
LastRow = 10
'loop through columns
For i = FirstCol To LastCol
MinValue = Application.WorksheetFunction.Min(ws1.Range(Cells(FirstRow, i), Cells(LastRow, i)))
MsgBox "The minimum value in the range is " & MinValue
Next i
End Sub
You can change the first and last row number or the column numbers as per your requirement.

How do I insert blank columns based on certain conditions?

I wanted to insert certain number of blank columns.
For example, row 1 column 1 is Q1, and row 1 column 2 is Q2, thus I dont need to insert any blank column.
If row 1 column 4 is Q5, row 1 column 3 is Q3, thus i want to insert (5-3-1) 1 blank column, a column to accommodate for Q4
Picture of the table is attached below.
https://imgur.com/NSatL9w
Sorry this is my first time writing on VBA. Any help is greatly appreciated.
Updated
Below is the error message displayed.
Compile error: Expected array
Option Explicit
Sub Test()
Dim lCol As Integer
Dim pos() As Long
Dim pos1() As Long
Dim strString() As String
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To lCol
If Left(Sheets(1).Cells(1, i).Value, 1) = "Q" Then
pos(i) = InStr(1, Cells(1,i), "Q") + 1
pos1(i) = InStr(pos(i), Cells(1,i), "<")
strString(i) = Mid(Cells(1,i), pos(i), pos1(i) - pos(i))
If strString(i + 1) - strString(i) > 1 Then
Columns(strString(i)+1:strString(i+1)-1).Insert
Shift:=xlToRight
End If
End If
Next i
End Sub
You have declared pos, pos1 and strStringas Integers then in your code you are using them as Arrays: pos(i), pos1(i), and strString(i+1). That is why you are getting the compile error Expected Array.
Also, when adding rows you need to move from the bottom up or adding columns from right to left. your counter should go from lCol to 1 Step -1.
You need to fully qualify your objects as well. Cells with no qualifier for which sheet will use whatever sheet is the active sheet, not necessarily the one you want to affect.
For the specific error, the variables pos, pos1 and strString need to be declared as arrays as we store multiple values and not only a single one.
This could be done in several difference ways:
'Method 1 : Using Dim
Dim arr1() 'Without Size
'Method 2 : Mentioning the Size
Dim arr2(5) 'Declared with size of 5
'Method 3 : using 'Array' Parameter
Dim arr3
arr3 = Array("apple","Orange","Grapes")
I will use Method 1, and after I know how many columns we need, I will resize/define the array so it will look like Method 2.
ActiveCell will not work as it refer to a single selection, so we need to change that to a dynamic reference.
Since you will add columns, your "total" range will be change for each inserted column. So if you have 14 columns from the beginning, you might miss the last ones as your range will have increased. I therefore recommend to start from right and loop to the left.
I also automatically added the headers for the new inserted column. Thought it could be a nice feature.
This code is hopefully something that can help you along:
Option Explicit
Sub test()
Dim lCol As Integer
Dim pos() 'Dim the variable as Array
Dim pos1() 'Dim the variable as Array
Dim strString() 'Dim the variable as Array
Dim i As Long 'Dim the variable i which will hold the position
Dim j As Long 'Dim the variable j which will loop for new inserted headers
Dim k As Long 'Dim the dummy variable k which will add one number for each empty header, between two quarters
lCol = Cells(1, Columns.Count).End(xlToLeft).Column 'Find the last column to loop through
ReDim pos(0 To lCol) 'When we know how many columns to loop through we can resize our array for the variable pos
ReDim pos1(0 To lCol) 'Same logic as above
ReDim strString(0 To lCol) 'Same logic as above
For i = lCol + 1 To 1 Step -1 'Since we want to insert a new column our "complete range will change". Therefore we start backwards and to Column A
If Left(Sheets(1).Cells(1, i).Value, 1) = "Q" Then 'Check if cell in row 1 starts with letter Q
pos(i) = InStr(1, Cells(1, i), "Q") + 1 'Get position for Q and add 1
pos1(i) = InStr(pos(i), Cells(1, i), "<") 'Get position for sign "<"
strString(i) = Mid(Cells(1, i), pos(i), pos1(i) - pos(i)) 'Extract the difference between "pos" and "pos1" to get which quarter we are dealing with
If ((strString(i + 1)) - strString(i)) > 1 And Not IsEmpty(strString(i + 1)) Then 'If the difference between cell "i +1" - cell "i" is larger than 1, and cell "i+1" is not empty, then..
Columns(i + 1).Resize(, ((strString(i + 1)) - strString(i)) - 1).Insert '... We use the difference between the cells and then resize our range which we want to insert
'### this part is only to create the header automatically, can be removed. ###
If ((strString(i + 1)) - strString(i)) > 2 Then 'If the difference is larger than 2, it means that we need to insert at least 2 columns or more
k = 1 'Set dummy variable k to 1
For j = i + 1 To strString(i) + (((strString(i + 1)) - strString(i)) - 1) 'Loop through the new empty inserted columns and add quarter headers
Cells(1, j).Value = "Q" & strString(i) + k & "<>"
k = k + 1 'Add one quarter
Next j
Else
Cells(1, i + 1).Value = "Q" & strString(i + 1) - ((strString(i + 1) - strString(i)) - 1) & "<>" 'Add Quarter headers if only one column was inserted
End If
'### --------------------------------------------------------------------- ###
End If
End If
Next i
End Sub
Final result:
you could avoid arrays:
Option Explicit
Sub Test()
Dim lCol As Long, i As Long
Dim qCurrent As Long, qPreceeding As Long
With Sheets(1) 'reference your sheet
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column ' start from referenced sheet row 1 last not empty column index
Do While lCol > 1 ' start iterating from last column
If Left(.Cells(1, lCol).Value, 1) = "Q" Then
qCurrent = Val(Mid(.Cells(1, lCol).Value, 2)) ' get current column"Q" value
qPreceeding = Val(Mid(.Cells(1, lCol - 1).Value, 2)) ' get preceeding column"Q" value
If qCurrent > qPreceeding + 1 Then ' if current "Q" is not consecutive of preceeding one
.Cells(1, lCol).EntireColumn.Resize(, qCurrent - qPreceeding - 1).Insert ' insert columns
For i = 1 To qCurrent - qPreceeding - 1 'loop to recreate new headers
.Cells(1, lCol + i - 1).Value = "Q" & qPreceeding + i & "<>"
Next
End If
End If
lCol = lCol - 1 ' step backwards
Loop
End With
End Sub

How to use Rows.Count function if there are blank cells in between data

I am trying to write a code that adds in data from my excel sheet if the item the user selects is equal to the range in J. This works perfectly if the range in J is filled in with all the data, but how do I get the row to still count all the way through the last filled cell if there are blanks in between? I attached a picture to show what I mean.
.
I would want to count the rows all the way down to the last "Gold". Right now it only counts to the second.
Private Sub cboName_Click() 'only get values that are assigned
Dim j As Integer, k As Integer, i As Integer
Me.lstProvider.Clear
i = 0
Worksheets("Biopsy Log").Select
For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count
If Range("J2", Range("J2").End(xlDown)).Cells(j) = Me.cboName.Value Then
If Range("C2", Range("C2").End(xlDown)).Cells(j) = "Assigned" Then
With Me.lstProvider
.AddItem
For k = 0 To 5
.List(i, k) = Range("A" & j + 1).Offset(0, k)
Next
End With
i = i + 1
End If
End If
Next
End Sub
Instead of For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count use Range("J" & Rows.Count).End(xlUp).Row (assuming GOLD is in column J). The code does the opposite of xlDown. It goes down to the last row of the sheet (Rows.count) and moves up until it find the first non-blank cell.
Instead of using xlDown, try to use xlUp from the bottom to get the last row for correct range:
Dim sht As Worksheet
Set sht = Worksheets("Biopsy Log")
For j = 1 To sht.Range("J" & sht.Rows.Count).End(xlUp).Row
If sht.Range(...)
Qualifying Range calls with an explicit Worksheet object makes your code more robust.

VBA Looping/Logic Issue

I am writing a macro in excel for work and I am having trouble. In this scenario there are two sheets, "BU" and "TOPS Information". When the macro is used it is supposed to search every line of "BU" for the value found in "TOPS Information", then go to the next line of "TOPS Information and repeat the process. If it finds a correct match it is supposed to copy a cell and paste it into "TOPS Information".
Here is the code:
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
This Macro obviously only works if "TOPS Information" is selected at the time. Any and all help would be most appreciated. THANKS!
You sorta answered it yourself. Range refers to the current sheet, but when you're bouncing around then you have to qualify it.
Prefix your ranges with the appropriate sheet like so,
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Sheets("TOPS Information").Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Sheets("TOPS Information").Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
Assuming only want to copy the top most found data in BU to TOPS, you can use below.
Sub QIM()
Dim oWS_TOPS As Worksheet, oWS_BU As Worksheet ' Worksheet objects
Dim oRng_TOPS As Range, oRng_BU As Range ' Range objects
Dim R_TOPS As Long, R_BU As Long
Set oWS_TOPS = ThisWorkbook.Worksheets("TOPS Information") ' <-- Replace this "TOPS Information" to match future changes
Set oWS_BU = ThisWorkbook.Worksheets("BU") ' <-- Replace this "BU" to match future changes
R_TOPS = oWS_TOPS.Cells(Rows.Count, "A").End(xlUp).Row
R_BU = oWS_BU.Cells(Rows.Count, "A").End(xlUp).Row
' Search column B of BU for each cell in column C of TOPS
For Each oRng_TOPS In oWS_TOPS.Columns("C").Cells ' <-- Replace this "C" to match future changes
' Exit if row is more than last A column data
If oRng_TOPS.Row > R_TOPS Then Exit For
For Each oRng_BU In oWS_BU.Columns("B").Cells ' <-- Replace this "B" to match future changes
' Exit if row is more than last A column data
If oRng_BU.Row > R_BU Then Exit For
' Check if Ranges match (## See Update ##)
If InStr(1, oRng_TOPS.Value, oRng_BU.Value, vbTextCompare) > 0 Then
' Copy column C of found row in BU to column H of TOPS, then exit
oWS_BU.Cells(oRng_BU.Row, "C").Copy oWS_TOPS.Cells(oRng_TOPS.Row, "H") ' <-- Replace these "C" and "H" to match future changes
Exit For
End If
Next
Next
Set oWS_TOPS = Nothing
Set oWS_BU = Nothing
End Sub
There are many ways to achieve your goal, and this is one of it.
UPDATE Note on comparing cell values (String):
StrComp(S1,S2[,mode]) only return 3 values {-1, 0, 1} to indicate if S1 is less/equal/greater than S2. If you want an exact match (case sensitive and exact spacing), use If StrComp(S1,S2) = 0 Then.
InStr([i,]S1,S2[,mode]) only returns positive values - it returns the character location of first appearance of S2 in S1. If S2 is not found then it returns zero.
You can also use Trim(sText) to remove leading/ending spaces of sText.
Hope below screenshot says more.

Resources