VBA Loop to Copy Columns - vba

I want to copy a defined number (lets say 10) of rows from one sheet ("Data") and paste it in another sheet ("Input). This will cause a bunch of stuff to calculate. Then I want to copy said calculated data (6 rows) from ("Input") to ("Data") and paste in a results table. THen I would repeat this a defined number of times for a certain number of columns (lets say 10).
I tried writing the code but it has literally been years since I have written code.
I used the Record Marco thing and got this:
Sub Macro2()
'
' Macro2 Macro
'
'
Range("C5:C14").Select
Selection.Copy
Sheets("Input").Select
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P12:P19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("C22").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D5:D14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Input").Select
Range("C5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P12:P19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("D22").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("G16").Select
End Sub
I hope this makes sense

Sub Macro2()
Const NUM_TIMES As Long = 10
Dim shtInput As Worksheet, shtData As Worksheet
Dim rngCopy As Range, i As Long
Set shtInput = Sheets("Input")
Set shtData = Sheets("Data")
Set rngCopy = shtData.Range("C5:C15")
For i = 1 To NUM_TIMES
With shtInput
.Range("C5").Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
.Calculate
rngCopy(1).Offset(17, 0).Resize(8, 1).Value = .Range("P12:P19").Value
End With
Set rngCopy = rngCopy.Offset(0, 1)
Next i
End Sub

Related

Copying and Pasting into a new Table Row using VBA

I am trying to figure this out and I am hoping you can help
Basically I have Form and Data Sheet. I am looking to copy the information in the form into a new blank row within Table1 on the data sheet,
I have managed to get as far as the following but this causes the data to be over written each time, (rather than a a new row).
Sub Macro1()
Sheets("Form").Select
Range("G5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[ID]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Contact Date]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Channel]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Agent Name]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("D6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Contact ID]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("G3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Scored by]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Form").Select
Range("G4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Data").Select
Range("Table1[[#Headers],[Team Leader]]").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
I realise this may seem like a simple question but I am struggling to work this out.
FYI - There will be 29 Columns to this table so If I should be doing something to make this cleaner, please let me know
Here's a more streamlined way to approach this:
EDIT - updated to add "config" array to reduce repetition
Sub Transfer()
Dim config, itm, arr
Dim rw As Range, listCols As ListColumns
Dim shtForm As Worksheet
Set shtForm = Worksheets("Form") '<< data source
With Sheets("Data").ListObjects("Table1")
Set rw = .ListRows.Add.Range 'add a new row and get its Range
Set listCols = .ListColumns 'get the columns collection
End With
'array of strings with pairs of "[colname]<>[range address]"
config = Array("ID<>G5", "Contact Date<>D3", "Channel<>D4")
'loop over each item in the config array and transfer the value to the
' appropriate column
For Each itm In config
arr = Split(itm, "<>") ' split to colname and cell address
rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
Next itm
End Sub
No copy/paste/select/activate required.

Vba/Macro to paste in next available row

I am trying to copy and paste certain cells that are not in the same column or row and paste them in Specific columns (it will be the same columns everytime). Once each entry is done, I want the next set of entries to paste on the next available row. The first set of code for Paste_NextRow() was ran as a macro and this was the code that was returned. The ranges I selected have formulas in them that will have different values each month. I am pasting them in a row with headers in row A. The second set of code for LastRow() I found this online and it will return the last row that is empty. I'm unsure how to utilize the second set of code to paste in the next available row. If you need additional context in order to help modify the code please let me know. Thanks. I've edited the text to show the code accordingly.
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
Sheets("SUMMARY DATA SHEET").Select
Range("F3").Select
Selection.Copy
Sheets("Invoice Number").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("F2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("B4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("F4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("F5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
End Sub
Sub LastRow()
NextRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
End Sub
Here is a quick rewrite setting a variable (called lastRow) to the last row in your invoice number tab.
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
'Get the last used row into a variable
Dim lastRow as Long
lastRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
'Copy Summary Data Sheet F3
Sheets("SUMMARY DATA SHEET").Range("F3").Copy
'And paste it into the last row (column F) of Invoice Number sheet
Sheets("Invoice Number").Range("F" & LastRow).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Use similar logic for the remaining cells
Sheets("SUMMARY DATA SHEET").Range("F2").Copy
Sheets("Invoice Number").Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Range("B4").Copy
Sheets("Invoice Number").Range("B" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Range("F4").Copy
Sheets("Invoice Number").Range("D" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Range("F5").Copy
Sheets("Invoice Number").Range("E" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
You'll see that there are no .Select happening here since Selecting a sheet or a cell is something a human does. There really isn't a need to do that in VBA where instead we can just specify exactly what we want to copy and where we want to paste it.
While this is cleaned up, it's still a little cumbersome to just copy and paste VALUES around the workbook. It uses the clipboard and has multiple statements for each copy/paste.
Instead we can just set the value of one cell equal to the value of another cell:
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
'Get the last used row into a variable
Dim lastRow as Long
lastRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
Sheets("Invoice Number").Range("F" & LastRow).Value = Sheets("SUMMARY DATA SHEET").Range("F3").value
Sheets("Invoice Number").Range("C" & lastRow).value = Sheets("SUMMARY DATA SHEET").Range("F2").value
Sheets("Invoice Number").Range("B" & lastRow).Value = Sheets("SUMMARY DATA SHEET").Range("B4").value
Sheets("Invoice Number").Range("D" & lastRow).Value = Sheets("SUMMARY DATA SHEET").Range("F4").value
Sheets("Invoice Number").Range("E" & lastRow).Value = Sheets("SUMMARY DATA SHEET").Range("F5").value
End Sub
Lastly, typing out those worksheet names over and over again is cumbersome. We can use a couple of variables to hold the two worksheets we care about. This is nice if you ever want to change worksheet names as you only have one place in the code to make the change:
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
'Set some variables to hold our worksheets
Dim wsCopy as Worksheet
Dim wsPaste as Worksheet
Set wsCopy = Sheets("SUMMARY DATA SHEET")
Set wsPaste = Sheets("Invoice Number")
'Get the last used row into a variable
Dim lastRow as Long
lastRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
'Copy values over
wsPaste.Range("F" & LastRow).Value = wsCopy.Range("F3").value
wsPaste.Range("C" & lastRow).value = wsCopy.Range("F2").value
wsPaste.Range("B" & lastRow).Value = wsCopy.Range("B4").value
wsPaste.Range("D" & lastRow).Value = wsCopy.Range("F4").value
wsPaste.Range("E" & lastRow).Value = wsCopy.Range("F5").value
End Sub

Calculate, Copy and Paste to a given value in VBA

I am fairly new to VBA. I am trying to automate iterations based on the no. of iterations specified in cell "E2". I want excel to Autofill down column A from cell "A4" to the value of cell "E2" e.g if E2 = 100, Excel will autofill series 1,2,3...down to 100.
I then want excel to continuosly calculate the value of cell "B2" then copy and paste each result down column B, starting at "B4" and stops at the value of iterations "E2"
I have the following code for the "Autofill"
Sub Monte3()
Dim srcRange As Range
Dim destRange As Range
Range("A5:A1000000").ClearContents
Set srcRange = ActiveSheet.Range("A4")
Set destRange = ActiveSheet.Range("A4:A103")
srcRange.AutoFill destRange, xlFillSeries
End Sub
I have recorded the following Macro for copy paste
Sub Macro10()
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Range("B2").Select
Selection.Copy
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
What's the easiest way to do this?
A nice For Each Next Loop should work. See the code below. I took some guesses on some of the range references based on what you wrote above, but you should be able to modify it easily to suit your needs.
Sub Monte3()
Dim srcRange As Range, cel As Range
Dim wks As Worksheet
Set wks = Sheets("Sheet1") 'replace Sheet1 with your sheet name
With wks
.Range("B5:B1000000").ClearContents
Set srcRange = .Range("B4:B" & .Range("E2").Value + 4) 'will plug the number in from E2 as the row and adds 4 since you are starting at row 4
For Each cel In srcRange
With .Range("B2")
.Calculate
.Copy
End With
cel.PasteSpecial xlPasteValues
Next
End With
End Sub

"if instr" not working with a loop

I am a VBA beginner. I am trying to build a macro that would copy and paste (value) an entire row to a new sheet based on a differentiation criteria. The differentiation criteria, in this case, would be the content of specific cell. In other words, if the cell contains the word "Caviar" then copy the row into sheet 1 otherwise copy into sheet 2. The following macro works when I run it manually (row one by one).
Sub Search_and_copy()
Dim rng As String
rng = Sheets("40").Range("F11").Value
Dim rowNo As Integer
rowNo = 6
Dim celltxt As String
celltxt = Sheets("40").Range("P11").Value
rowNo = 6
If Sheets("40").Range("F11").Value = "254" Then
If InStr(celltxt, "CAVIAR") Then
Rows("11:11").Select
Selection.Copy
Sheets("Sheet1").Select
If IsEmpty(Cells(rowNo, 1)) Then
Sheets("Sheet1").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else: Do Until IsEmpty(Cells(rowNo, 1))
rowNo = rowNo + 1
Loop
Sheets("Sheet1").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Sheets("40").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Else
Rows("11:11").Select
Selection.Copy
Sheets("Sheet2").Select
If IsEmpty(Cells(rowNo, 1)) Then
Sheets("Sheet2").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else: Do Until IsEmpty(Cells(rowNo, 1))
rowNo = rowNo + 1
Loop
Sheets("Sheet2").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Sheets("40").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End If
End If
End Sub
However, as soon as I introduce a loop (see code below), the differentiation is no longer properly made and all rows are copied into the same worksheet. What am I doing wrong?
Sub Search_and_copy()
Dim rng As String
rng = Sheets("40").Range("F11").Value
Dim rowNo As Integer
rowNo = 6
Dim celltxt As String
celltxt = Sheets("40").Range("P11").Value
Do Until IsEmpty(Sheets("40").Range("F11").Value)
rowNo = 6
If Sheets("40").Range("F11").Value = "254" Then
If InStr(celltxt, "CAVIAR") Then
Rows("11:11").Select
Selection.Copy
Sheets("Sheet1").Select
If IsEmpty(Cells(rowNo, 1)) Then
Sheets("Sheet1").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else: Do Until IsEmpty(Cells(rowNo, 1))
rowNo = rowNo + 1
Loop
Sheets("Sheet1").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Sheets("40").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Else
Rows("11:11").Select
Selection.Copy
Sheets("Sheet2").Select
If IsEmpty(Cells(rowNo, 1)) Then
Sheets("Sheet2").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else: Do Until IsEmpty(Cells(rowNo, 1))
rowNo = rowNo + 1
Loop
Sheets("Sheet2").Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Sheets("40").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End If
End If
Loop
End Sub
The (first) problem is that you never change the value of celltxt inside your loop. After you read Sheets("40").Range("P11").Value into the string, you never change it. This means that InStr(celltxt, "CAVIAR") will always be the same until the Sub ends. All you should need to do is update it inside your loop.
One other thing to do while you're at it is to apply a little DRY and extract your common code into a function. The only difference between your If and Else is the sheet name. Try something like this:
Sub Search_and_copy()
Dim celltxt As String
Do Until IsEmpty(Sheets("40").Range("F11").Value)
celltxt = Sheets("40").Range("P11").Value
If Sheets("40").Range("F11").Value = "254" Then
If InStr(celltxt, "CAVIAR") Then
DontRepeatYourself "Sheet1"
Else
DontRepeatYourself "Sheet2"
End If
End If
Loop
End Sub
Private Sub DontRepeatYourself(sheet As String)
Dim rowNo As Long
rowNo = 6
Rows("11:11").Select
Selection.Copy
Sheets(sheet).Select
Do Until IsEmpty(Cells(rowNo, 1))
rowNo = rowNo + 1
Loop
Sheets(sheet).Cells(rowNo, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("40").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub

Calling a sub within a loop

was trying to call a sub(trialMacro) from inside another sub(Macro2) but somehow it does not get activated. Is there a reason why? The call function works fine if its not within the loop. I.e. if I just do a plain call function under another sub. Is my coding right? I'm not sure if the loop disrupts the execution
' trial Macro
Sub trialMacro()
Dim PrevCell As Range
Set PrevCell = ActiveCell
SolverOk SetCell:=ActiveCell, MaxMinVal:=2, ValueOf:="0", ByChange:= _
"$M$2,$M$3,$M$5,$M$7"
SolverSolve UserFinish:=True
SolverFinish KeepFinal:=1
'Copy in sample and out of sample error
PrevCell.Resize(1, 3).Copy
'Paste Values of in sample and out of sample errors
PrevCell.Offset(0, 4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Copy Co-efficient
Range("M2:M7").Select
Application.CutCopyMode = False
Selection.Copy
'Select paste destination
PrevCell.Offset(0, 7).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'Copy Paste Following months data
PrevCell.Offset(1, -1).Resize(12, 1).Copy
'Select target destination
PrevCell.Offset(0, 13).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
PrevCell.Offset(1, 0).Select
End Sub
Sub Macro2()
'
' Macro2 Macro
Dim i, j As Integer
For i = 50 To 162
For j = 0 To 113
Sheets("Model v2 DUBDAT >0").Cells(i, 17).Select
Call trialMacro
Range("P50:BA50").Offset(j, 0).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Reference Sheet").Select
Range("D6").Offset(j, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Model v2 DUBDAT >0").Select
Next
Next
End Sub
Give this a read...
https://msdn.microsoft.com/en-us/library/office/gg251432.aspx
Remove call from this line
Call trialMacro
Should be..
trialMacro
If you use the call statement the subname must be followed by parentheses.