I want to copy gray cells to rows but only last column gray cell copied.
There's no need for nested loops
Sub Test()
Dim r As Integer, c As Integer
r = 3
For c = 3 To 21 Step 3
Cells(r, 1) = Cells(1, c)
r = r + 1
Next c
End Sub
You are so close :)
Option Explicit
Sub istebu()
Dim x As Long
Dim i As Long
For i = 3 To 10 'Loop in row from 3 to 10
For x = 3 To 21 Step 3 'Loop header row, from 3 to 21, jump 3
Cells(i, 1) = Cells(1, x) 'Copy values.
i = i + 1 'Add one row each time, so we don't overwrite previously row
Next x
Next i
End Sub
Alternative:
It could be shortened as we don't need to loop through the rows. We only need to add them. So we set i to the start row where we should paste our data.
Sub istebu()
Dim x As Long
Dim i As Long
i = 3 'Set first row number you want to loop from.
For x = 3 To 21 Step 3 'Loop header row, from 3 to 21, jump 3
Cells(i, 1) = Cells(1, x) 'Copy values.
i = i + 1 'Add one row each time, so we don't overwrite previously row
Next x
End Sub
There is an alternative to loops altogether.
Range("C1,F1,I1,L1,O1,R1,U1").Copy
Range("A3").PasteSpecial Paste:=xlPasteValues, Transpose:=True
But if you're really into loops, use one to build a union.
dim i as long, rng as range
for 3 to 21 step 3
if rng is nothing then
set rng = cells(1, i)
else
set rng = union(rng, cells(1, i))
end if
next i
rng.Copy
Range("A3").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Related
I am trying to do a "for each" sub in VBA, comparing two pairs of rows and the values in each cell to one another. For example row 2 is compared with row 3, row 4 is compared with row 5 etc. I need the code to highlight the differences in each cell for each of the comparisons. This is what I have so far and I cannot seem to get it to work. Any thought?
Sub testing_2()
Dim rw_2 As Range, rw_1 As Range, decisions As String
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
For Each rw_1 In Worksheets("worksheet").Rows
For Each rw_2 In Worksheets("worksheet").Rows
If Not StrComp(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1, vbBinaryCompare) = 0 Then
Range(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1).Interior.ColorIndex = 6
End If
Next rw_2
Next rw_1
Else: End If
End Sub
Thank you!
Basically, I am looking at each row, two at a time, and highlighting the different values between them.
One loop to to loop the rows stepping 2 rows at a time and another loop to loop the columns
Sub testing_2()
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
With Worksheets("Sheet4") ' change to your sheet
Dim lstRw As Long
lstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim lstClm As Long
lstClm = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long
For i = 2 To lstRw Step 2
Dim j As Long
For j = 2 To lstClm
If .Cells(i, j) <> .Cells(i + 1, j) Then
.Range(.Cells(i, j), .Cells(i + 1, j)).Interior.ColorIndex = 6
End If
Next j
Next i
End With
End If
End Sub
I would like to make every set of eight rows move into columns in Excel for example here is a set with every four rows broken into columns:
From this:
To this:
I've tried this code in VBA which I've seen in a previous question found on https://superuser.com/questions/583595/move-every-7-columns-into-new-row-in-excel
Dim i As Integer, j As Integer, cl As Range
Dim myarray(100, 6) As Integer 'I don't know what your data is. Mine is integer data
'Change 100 to however many rows you have in your original data, divided by seven, round up
'remember arrays start at zero, so 6 really is 7
If MsgBox("Is your entire data selected?", vbYesNo, "Data selected?") <> vbYes Then
MsgBox ("First select all your data")
End If
'Read data into array
For Each cl In Selection.Cells
Debug.Print cl.Value
myarray(i, j) = cl.Value
If j = 6 Then
i = i + 1
j = 0
Else
j = j + 1
End If
Next
'Now paste the array for your data into a new worksheet
Worksheets.Add
Range(Cells(1, 1), Cells(101, 7)) = myarray
End Sub
However, it only seems to work with integers and not data that has both numbers and letters if I am understanding correctly.
I get an error:
Run-time error '13':
Type mismatch
This should do it
Sub movedata()
Dim rowcounter, colcounter, rowcounter2 As Long
colcounter = 3
rowcounter2 = 1
For rowcounter = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
If Cells(rowcounter, 1).Value2 <> "" Then
Cells(rowcounter2, colcounter).Value2 = Cells(rowcounter, 1).Value2
colcounter = colcounter + 1
Else
rowcounter2 = rowcounter2 + 1
colcounter = 3
End If
Next rowcounter
End Sub
So you basically want to transpose the used range of a given sheet? This code may
Option Explicit
Sub transpose()
Dim a As Integer, x As Integer
a = 1 + Cells(1, 1).End(xlToRight).Column
ActiveSheet.UsedRange.Copy
Cells(1, a).Select
Selection.PasteSpecial Paste:=xlPasteAll, transpose:=True
Cells(1, 1).Select
For x = 1 To (a - 1)
Columns(1).Delete
Next x
End Sub
It works as follows:
- find the last used column and define "a" as this columnnumber + 1
- Copy the used range (where your data is)
- transpose into cells(1,a)
- select cells(1,1)
- delete this column (a-1) times
Is this what you are looking for?
I want to change rows 2 to 10 in column 4 to 10 but it does not work.
Restriction: d As Single must not be changed
Sub ua()
Dim d As Single
Dim i As Integer
d = Cells(i, 4)
For i = 2 To 10
d = 10
Next i
End Sub
Looping through the rows and columns is one option:
Sub TestMe()
Dim myRow As Long, myCol As Long
Dim d As Single: d = 10
For myRow = 2 To 10
For myCol = 4 To 10
Worksheets(1).Cells(myRow, myCol) = d
Next myCol
Next myRow
End Sub
Another one is using the single line solution of #Jeep from the comments -
With Workheets(1)
.Range(.Cells(2, 4), .Cells(10, 10)) = 10
end with
Change Sheet name and try:
Sub test()
With Sheet1
.Range(.Cells(2, 4), .Cells(10, 10)).Value = 10
End With
End Sub
You actually doing nothing with your code (you just set a variable and then you loop without any restult on cell values). If you want to change a value in a cell you have to write this in your code. You can change a value in a cell like this:
Cells(3, 2).Value = 2
If you want this variable and in a loop you can write the following:
For i = 2 to 10
Cells(3, i).Value = 1000 'Set the value of the cell to 1000
Next i
If I have a long list of text in Column A, and a short list of words in Column C, what would be the best way to go about searching each cell in A for any of the words in C, and copy and paste the ones that match out into Column B?
The code I have written so far is as follow
Sub ListKeywordQualifier()
Dim Rng As Range
Dim Keyword As Range
Dim Chunk As Range
Dim x As Long
x = 1
While x <= 5000
Set Rng = Range("A" & x)
Set Chunk = Range("C1", "C100")
Application.ScreenUpdating = True
Range("D1").Value = x
If Application.WorksheetFunction.CountIf(Chunk, Rng) = 0 Then
x = x + 1
ElseIf Application.WorksheetFunction.CountIf(Chunk, Rng) = 1 Then
Rng.Copy
Rng.Offset(0, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
x = x + 1
End If
Wend
End Sub
However, this will onl;y give me exact matches between the two. Is it possible to do the same, but have text that appears in Column C, while only making up part of Column A, trigger the copy/paste line?
Thanks
your countif is not working because it is a worksheet function, to implement countif.... you need to write it like
WorksheetFunction.CountIf . Still your code is not looking Good , Try This!
Sub ListKeywordQualifier()
Dim Rng(50) As String
Dim Chunk(50) As String
Dim i As Long
i = 1
'' Take a value From 3rd Column this works for 10 cells ,
For i = 1 To 10
Chunk(i) = Cells(i, 3)
''Search it in 1st Column in 10 cells
For j = 1 To 10
Rng(j) = Cells(j, 1)
''If it matches
If Chunk(i) = Rng(j) Then
''Then copy that value to Second Column
Cells(i, 2).Value = Rng(j)
End If
Next j
Next i
End Sub
This is just to give you an idea , you still need make changes Thanks
Consider:
Sub ListKeywordQualifier()
Dim A As Range, C As Range, aa As Range, cc As Range
Dim K As Long, va, vc, boo As Boolean
Set A = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set C = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
K = 1
For Each aa In A
va = aa.Value
boo = False
For Each cc In C
If InStr(1, va, cc.Value) > o Then boo = True
Next cc
If boo Then
aa.Copy Cells(K, "B")
K = K + 1
End If
Next aa
End Sub
Before:
and after:
I have the following loop written,
For X = 1 To N
Rng.Offset(, -3).Resize(, 670).Copy
Rng.Offset(1, -3).Insert Shift:=xlDown
Next X
i = i + N
Which is supposed to start on a row (defined by i), and make new rows based on what N is. If N is equal to 20, I want this code to make 20 copies, then move onto the next row. However, on row 1, N = 3, and copy/pasting just seems to happen over and over. Any suggestions?
For context, the entire the code is as follows:
Sub NuPubPrepare()
Dim i As Long, k As Long, N As Long, Entry As Range, Rng As Range
i = 2
While i <= 400
Set Entry = Range("K" & i)
For k = Columns("K").Column To Columns("GB").Column Step 5
Set Entry = Union(Entry, Cells(i, k))
Next k
Set Rng = Range("D" & i)
N = Application.WorksheetFunction.CountA(Entry)
If N = 1 Then
i = i + 1
Else
For X = 1 To N
Rng.Offset(, -3).Resize(, 670).Copy
Rng.Offset(1, -3).Insert Shift:=xlDown
Next X
i = i + N
End If
Wend
End Sub
So N will count the number of cells with data in them across a wide range (Every 5 cells from Ki to GBi), and I'm trying to make the script insert new lines based on this number.
This will do as you ask.
Sub test()
Dim rng As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("1:1")
For i = 1 To 5
rng.Offset(1).Insert Shift:=xlDown
rng.Copy
rng.Offset(1).PasteSpecial xlPasteValues
Next i
End Sub