I have an Excel spreadsheet with answers to questions for an exam. It is set up as a series of 4x2 blocks. Each block has the 4 multiple choice answers in the first column, and then a 0 or a 1 in the column to the right indicating correct or incorrect.
I want to make a macro to take the 2nd, 3rd, and 4th answer and corresponding 0/1 cell and paste them so they end up to the right of the 1st answer in the block. I have this macro so far, which successfully edits the first answer and correctness indicator column:
Range("A2:B2").Select
Selection.Cut
Range("C1").Select
ActiveSheet.Paste
Range("A3:B3").Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste
Range("A4:B4").Select
Selection.Cut
Range("G1").Select
ActiveSheet.Paste
How can I change it so that it will do cells 2, 3, 4, 6, 7, 8, 10, 11, 12, etc. but skip 1, 5, 9, etc.?
Thanks!
Given an input of:
Using code:
Sub QReform()
Dim CurRow As Long, LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For CurRow = LastRow To 1 Step -1
If ((CurRow - 1) / 5) - ((CurRow - 1) \ 5) = 0 Then
Cells(CurRow, 2).Value = Cells(CurRow, 1).Offset(1, 0).Value
Cells(CurRow, 3).Value = Cells(CurRow, 1).Offset(1, 1).Value
Cells(CurRow, 4).Value = Cells(CurRow, 1).Offset(2, 0).Value
Cells(CurRow, 5).Value = Cells(CurRow, 1).Offset(2, 1).Value
Cells(CurRow, 6).Value = Cells(CurRow, 1).Offset(3, 0).Value
Cells(CurRow, 7).Value = Cells(CurRow, 1).Offset(3, 1).Value
Cells(CurRow, 8).Value = Cells(CurRow, 1).Offset(4, 0).Value
Cells(CurRow, 9).Value = Cells(CurRow, 1).Offset(4, 1).Value
Cells(CurRow, 1).Offset(4, 0).EntireRow.Delete xlShiftUp
Cells(CurRow, 1).Offset(3, 0).EntireRow.Delete xlShiftUp
Cells(CurRow, 1).Offset(2, 0).EntireRow.Delete xlShiftUp
Cells(CurRow, 1).Offset(1, 0).EntireRow.Delete xlShiftUp
End If
Next CurRow
End Sub
Will give you this:
I ended up moving the columns into a text editor and using regex to do the work, as that was a much simpler way of doing it. I searched for blocks of 4 lines and replaced returns with tabs where appropriate so it would fit on one line and go back into Excel easily.
Related
Here is my code:
For j = 3 To 37 Step 2
If PaddleBDateInstalledTextBox.Value = Cells(j, 8).Value Then
Cells(j, 8).Copy
Range("D42").PasteSpecial Paste:=xlPasteValues
Range("D42").PasteSpecial Paste:=xlPasteFormats
Range("D42").PasteSpecial Paste:=xlPasteAllUsingSourceTheme '<--
cells background, etc.
Range("D42").NumberFormat = "MM/DD/YY"
Cells(j, 8).Clear
End If
Next
I have one cell where the format is a date and I am trying to copy it first and then paste it into another cell but my cell did not have the value pasted in it and the original cell; and the contents were not cleared.
I have another cell that has the format Today() and I want to just copy the value without the formula into another cell but i have failed as well.
The last cell that I want to copy has a formula of =($I$2-H2)+(G2-F2) and I have the same problem.
This code worked for me:
If 1 = Cells(1, 1).Value Then 'Assuming in Cell(1, 1) is the value 1
Cells(1, 1).Copy
Range("B1").PasteSpecial Paste:=xlPasteValues
Range("B1").PasteSpecial Paste:=xlPasteFormats
Range("B1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Range("B1").NumberFormat = "MM/DD/YY"
Cells(1, 1).Clear
End If
Maybe the Cells(j, 8).Value is your problem. What value does j have? If j is a variable your code should be right, but if you mean J as column name the code should be Range("J" & 8).Value or Cells(8, "J").Value instead of Cells(j, 8).Value
I have three sheets, sheet S, Sheet P and Sheet Data.
I first copy the column of Sheet S to Sheet Data. Then in column E of sheet Data, I look for the ID. The ID In column E of data sheet, matches with the column A of P sheet, then I copy the corresponding ID.
The problem here is the Sheet data contains 214 rows, while sheet P contains 1110.
while comparing the ID, there are two different ID from row 870 and 871, which are not copied, even though they are same.
Could someone guide what could be the reason ?
Sub lookup()
Dim lLastrow, totalrows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from S to Data
With Sheets("S")
lLastrow = .Cells(.Rows.count, 1).End(xlUp).Row
.Range("P5:P" & lLastrow).Copy Destination:=Sheets("Data").Range("E5")
.Range("G5:G" & lLastrow).Copy Destination:=Sheets("Data").Range("H5")
End With
totalrows = Sheets("P").Cells(Sheets("P").Rows.count, "A").End(xlUp).Row
For i = 5 To lLastrow
'Search for the value on P_APQP
With Sheets("P")
Set rng = .Columns(1).Find(Sheets("Data").Cells(i, 5).Value & "*", lookat:=xlWhole)
End With
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
With Sheets("Data")
.Cells(i, 6).Value = rng.Value
.Cells(i, 1).Value = rng.Offset(0, 1).Value
.Cells(i, 2).Value = rng.Offset(0, 2).Value
.Cells(i, 3).Value = rng.Offset(0, 3).Value
.Cells(i, 4).Value = rng.Offset(0, 9).Value
.Cells(i, 9).Value = rng.Offset(0, 10).Value
.Cells(i, 13).Value = rng.Offset(0, 6).Value
.Cells(i, 14).Value = rng.Offset(0, 5).Value
.Cells(i, 15).Value = rng.Offset(0, 4).Value
.Cells(i, 16).Value = rng.Offset(0, 8).Value
End With
End If
Next i
End Sub
I'll post the whole code. I also made an adjustment to your first line of declarations - as you had it, only totalrows was being declared as Long. You have to spell each one out I'm afraid.
Sub lookup()
Dim lLastrow As Long, totalrows As Long
Dim rng As Range
Dim i As Long
With Sheets("S")
lLastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("P5:P" & lLastrow).Copy Destination:=Sheets("Data").Range("E5")
.Range("G5:G" & lLastrow).Copy Destination:=Sheets("Data").Range("H5")
End With
totalrows = Sheets("P").Cells(Sheets("P").Rows.Count, "A").End(xlUp).Row
For i = 5 To lLastrow
'Search for the value on P_APQP
With Sheets("P")
'amended below
Set rng = .Columns(1).Find(Trim(Sheets("Data").Cells(i, 5).Value) & "*", lookat:=xlWhole)
End With
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
With Sheets("Data")
.Cells(i, 6).Value = rng.Value
.Cells(i, 1).Resize(, 3).Value = rng.Offset(0, 1).Value
.Cells(i, 2).Value = rng.Offset(0, 2).Value
.Cells(i, 3).Value = rng.Offset(0, 3).Value
.Cells(i, 4).Value = rng.Offset(0, 9).Value
.Cells(i, 9).Value = rng.Offset(0, 10).Value
.Cells(i, 13).Value = rng.Offset(0, 6).Value
.Cells(i, 14).Value = rng.Offset(0, 5).Value
.Cells(i, 15).Value = rng.Offset(0, 4).Value
.Cells(i, 16).Value = rng.Offset(0, 8).Value
End With
End If
Next i
End Sub
The following script selects a range of data on one sheet and transfers the selection to another sheet.
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.Save
End If
Next i
I would now like to introduce a script which will replace the row of data on the target sheet if the value in column A already exists, but i'm not sure how to achieve this, any help is much appreciated.
Thank you in advance.
Public Function IsIn(li, Val) As Boolean
IsIn = False
Dim c
For Each c In li
If c = Val Then
IsIn = True
Exit Function
End If
Next c
End Function
dim a: a= range(destWB.sheet(whatever)..range("A1"),destWB.Range("A" & destWB.sheet(whatever).Rows.Count).End(xlUp)).value
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
if isin(a, Cells(i, 1) ) then
do whatever you want
else
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.save
End If
End If
Next i
I suggest using a Dictionary-Object which is most likely a Hash-Map. The advantage is that you can use the built in method Dictionary.Exists(Key) to check if the Dictionary already holds the specified value (Key).
Also you should not save the Workbook in every step of the iteration. It would be better (and faster) to only save the workbook after completing the copying of your whole data.
Additionally your If-Tests after copy-paste are not neccessary, because you are already checking for Cells(i,1)<>"" before copying so you don't have to check this again as it does not change.
The following code shows how to get your desired result:
Set dict = CreateObject("Scripting.Dictionary")
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
If dict.Exists(Cells(i,1).Value) Then
'value already exists -> update row number
dict.Item(Cells(i,1).Value)=i
Else
'save value of column A and row number in dictionary
dict.Add Cells(i,1).Value, i
End If
Cells(i, 22).Value = "Yes"
Cells(i, 23).Value = Now
Cells(i, 24).Value = Environ("UserName")
End If
Next i
'finally copy over your data (only unique values)
For Each i In dict.Items
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
Next i
I am learning visual basic and this script I'm using is coming up with an error when I am initializing the variable i.
I'm not sure what the problem is but I am getting the error message:
Run-time error '1004': Application-defined or object-defined error
Here is my code:
Sub excelmacro()
Sheets("Sheet1").Select
Range("A1").Select
Sheets("Sheet2").Select
Range("B1").Select
i = 1
While i <> 10
If Len(ActiveCell.Value) > 1 Then
Sheets("Sheet1").Select
xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
xsalary = Right(ActiveCell.Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
xdesignation = Right(ActiveCell.Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
Sheets("Sheet2").Select
ActiveCell.Value = xname
ActiveCell.Offset(0, 1).Value = xdesig
ActiveCell.Offset(0, 3).Value = xsalary
ActiveCell.Offset(1, 0).Select
Sheets("Sheet1").Select
ActiveCell.Offset(3, 0).Select
Else
i = 10
End If
Wend
End Sub
you do not need the variable i in your code anyway! just kick the line initializing i out.
The if statement in your loop that uses i is basically to escape the loop and can be shortened to:
While Len(ActiveCell.Value) > 1
Sheets("Sheet1").Select
xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
xsalary = Right(ActiveCell.Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
xdesignation = Right(ActiveCell.Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
Sheets("Sheet2").Select
ActiveCell.Value = xname
ActiveCell.Offset(0, 1).Value = xdesig
ActiveCell.Offset(0, 3).Value = xsalary
ActiveCell.Offset(1, 0).Select
Sheets("Sheet1").Select
ActiveCell.Offset(3, 0).Select
Wend
This may be a good time to start practising the methods detailed in How to avoid using Select in Excel VBA macros.
Your code is repeatedly retrieving different lengths of the right-most characters from ActiveCell but using the length of the values from rows below the active cell to determine how many characters to retrieve. It seems that you should be retrieving the characters from the same cell that you are using to determine the length.
Sub excelmacro()
Dim i As Long, xname As String, xsalary As String, xdesignation As String
With Sheets("Sheet1")
For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row Step 3
If CBool(Len(.Cells(i, "A").Value)) Then
xname = Right(.Cells(i, "A").Value, Len(.Cells(i, "A").Value) - 6)
xdesignation = Right(.Cells(i + 1, "A").Value, Len(.Cells(i + 1, "A").Value) - 13)
xsalary = Right(.Cells(i + 2, "A").Value, Len(.Cells(i + 2, "A").Value) - 8)
With Sheets("Sheet2")
.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = xname
.Cells(Rows.Count, "B").End(xlUp).Offset(0, 1) = xdesignation
.Cells(Rows.Count, "B").End(xlUp).Offset(0, 3) = xsalary
End With
End If
Next i
End With
End Sub
I've retained your use of a string variable for the salary although you may be better served by using a variable of type double and converting the text with a CDbl() wrapper. The second use of xdesig instead of xdesignation was corrrected.
why does this not work? Basically i have a list in a single cell i want to split strings ending in "sec" and ones that don't by copying them into different columns.
Sub test_if()
For i = 1 To 300
Cells(i, 2).Select
If Right(Cells(i, 2), 3) = "SEC" Then
ActiveCell.Select
Selection.Copy
Cells(i, 3).Select
ActiveSheet.Paste
End If
If Right(Cells(i, 2), 3) <> "SEC" Then
ActiveCell.Select
Selection.Copy
'Cells(i, 4).Select
ActiveCell.Offset(i - 1, 2).Select
ActiveSheet.Paste
End If
Next i
Cells(1, 1).Select
End Sub
Try this one:
Sub test_if()
Dim i As Integer
For i = 1 To 300
With Cells(i, 2)
If UCase(Right(.Value, 3)) = "SEC" Then
.Offset(, 1).Value = .Value
Else
.Offset(i - 1, 2).Value = .Value
End If
End With
Next i
End Sub
and also read, please, how to avoid using Select/Active statements