I have the following code, which copies and pastes values from one sheet to another, depending on the number of rows and columns. The code works great when copying each value one-by-one. However, the dataset that I am currently working with will always have values in rows 11 to 110 (100 values total), with only the column changing.
Hence, how can I alter the lines of code with the arrows (<--) so that it always copies rows 11 to 110, offsetting only the column number?
Option Explicit
Sub Transpose_Lapse_LevelTrend()
Dim ws As Worksheet
Dim i, k, multiple As Integer
Dim rawrowcount As Long
Dim rawcolcount As Long
'Define variables for the below-noted code
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name = "Q_Sheet7.1" Then
ActiveWorkbook.Sheets(i).Delete
End If
Next i
'Delete Worksheet if already existing for respective tab
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Q_Sheet7.1"
ws.Range("A1").Value = "Year"
ws.Range("B1").Value = "Product"
ws.Range("C1").Value = "Cashflow"
End With
With ThisWorkbook.Sheets("7.1")
.Range("A:A").Delete
rawrowcount = WorksheetFunction.CountA(.Range("A:A")) - WorksheetFunction.CountA(.Range("A1:A10")) - 1
rawcolcount = .Cells(10, Columns.Count).End(xlToLeft).Column - 2
End With
'Count the number of rows and columns to determine how many the number of iterations
'for the next set of code
Application.ScreenUpdating = False
'Do not update screen while executing code
For i = 1 To rawcolcount
multiple = rawrowcount * (i - 1)
For k = 1 To rawrowcount
'Sheets("7.1").Activate <--
'ActiveSheet.Range("A9").Select <--
'Selection.Offset(k + 1, 0).Select <--
'Selection.Copy <--
'Sheets("Q_Sheet7.1").Activate <--
'ActiveSheet.Range("A1").Select <--
'Selection.Offset(k + multiple, 0).Select <--
'ActiveSheet.Paste <--
'Copy and paste Years 1 to 100
Sheets("7.1").Activate
ActiveSheet.Range("A9").Select
Selection.Offset(k + 1, i).Select
Selection.Copy
Sheets("Q_Sheet7.1").Activate
ActiveSheet.Range("A1").Select
Selection.Offset(k + multiple, 2).Select
ActiveSheet.Paste
'Copy and paste the Cashflow for Years 1 to 100 for
'each Product
Next k
'Repeat for each Product Type
Sheets("7.1").Activate
ActiveSheet.Range("A9").Select
Selection.Offset(2, 0).Select
Selection.Copy
Sheets("Q_Sheet7.1").Activate
ActiveSheet.Range("A1").Select
Selection.Offset(multiple + 1, 0).Select
ActiveSheet.Paste
'Copy & paste the Year for each respective Cashflow
'Sheets("7.1").Activate
'ActiveSheet.Range("B7").Select
'Selection.Offset(0, i).Select
'Selection.Copy
'Sheets("Q_Sheet7.1").Activate
'ActiveSheet.Range("A1").Select
'Selection.Offset(multiple + 1, 1).Select
'ActiveSheet.Paste
'Copy & paste Region for the respective Cashflow
Sheets("7.1").Activate
ActiveSheet.Range("A9").Select
Selection.Offset(1, i).Select
Selection.Copy
Sheets("Q_Sheet7.1").Activate
ActiveSheet.Range("A1").Select
Selection.Offset(multiple + 1, 1).Select
ActiveSheet.Paste
'Copy & paste the Product for each respective Cashflow
'Sheets("7.1").Activate
'ActiveSheet.Range("B8").Select
'Selection.Offset(0, i).Select
'Selection.Copy
'Sheets("Q_Sheet7.1").Activate
'ActiveSheet.Range("A1").Select
'Selection.Offset(multiple + 1, 3).Select
'ActiveSheet.Paste
'Copy & paste Risk for the respective Cashflow
ActiveSheet.Range(ActiveSheet.Cells(multiple + 2, 1), ActiveSheet.Cells(multiple + 2, 2)).Select
Selection.AutoFill Destination:=Range(ActiveSheet.Cells(multiple + 2, 1), ActiveSheet.Cells(multiple + 101, 2))
'Autofill the Region, Product and Product Type for each Cashflow
Next i
'Repeat for Years 1 to 100
Application.ScreenUpdating = False
'Do not update screen while executing code
ThisWorkbook.ActiveSheet.Cells.ClearFormats
'Clear formatting in Output Worksheet
Set ws = Nothing
End Sub
What you want to do is stay away from using Select/Selection etc and rather use indexed based direct references such as Ranges. I used Select/Selection in the begining as well. Here is some data on How to avoid using Select in Excel VBA macros
I am not exactly sure as to what your script is doing with the Multiple etc, but the script below will copy the Cells 10 to 100 from Sheet 7.1 and paste the in sheet Q_Sheet7.1 in Range A1:100 it will do this for Columns 1 to 10.
I am sure you can adapt it to your script.
Sub CopyPasteUsingRange()
Dim oRng As Range
Dim Sht71 As Worksheet
Dim ShtQ71 As Worksheet
Dim rawcolcount As Long
Set Sht71 = ActiveWorkbook.Worksheets("7.1")
Set ShtQ71 = ActiveWorkbook.Worksheets("Q_Sheet7.1")
'just for my example
rawcolcount = 10
For i = 1 To rawcolcount
Set oRng = Range(Sht71.Cells(10, i), Sht71.Cells(110, i))
oRng.Copy
ShtQ71.Range(Cells(1, i), Cells(110, i)).PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone
Next i
End Sub
Related
In the code below, my LastRow variable is not storing the right row number on the 27th loop (i = 27) causing the code to malfunction
I have used the F8 step through multiple times and noticed that the issue is on the 27th loop. The LastRow variable is meant to be +1204 rows from the previous LastRow value on each iteration of the loop, so I was expecting LastRow = 32509 instead of LastRow = 31316. For reference, on the 26th loop, LastRow = 31305. I'm not sure why the it is finding the wrong LastRow when the code has worked for the first 26 loops.
I am trying to get from my Source Table to my Desired Table:
Source Table
to
Desired Table
Also , the final error that shows is:
Run-Time error '1004': Application -defined or object- defined error
Sub Populate_entity()
Dim i As Integer
i = 1
Dim LastRow As Long
Dim SearchText As String
Do While i < 122 ' go across entity (columns wise)
If i = 1 Then
Range("E1").Select
Selection.Copy
SearchText = ActiveCell.Value
ActiveCell.End(xlToLeft).Select 'snap to left (cell A1)
ActiveCell.Offset(0, 2).Select 'move to cell C1
ActiveCell.Offset(1, 0).Select ' move to cell C2
Else
ActiveCell.Offset(0, i + 1).Select
Selection.Copy
SearchText = ActiveCell.Value
ActiveCell.End(xlToLeft).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End If
ActiveSheet.Paste
ActiveCell.Offset(1203, 0).Select
ActiveSheet.Paste
ActiveCell.End(xlUp).Select
' ======== Error here ========
LastRow = Cells.Find(What:=SearchText, After:=ActiveCell, LookIn:=xlValues, SearchOrder:=xlByRows).Row
Range("C" & ActiveCell.Row & ":C" & LastRow).FillDown
ActiveCell.End(xlUp).Select
i = i + 1
Loop
End Sub
A summary of what you want, as you described in the comments:
Copy the values from cells E1:DU1, paste each cell 1204 times in column C.
1st loop it will paste cell E1 in C2:C1205
2nd loop it will paste cell F1 to C1206:C2409
etc.
This code achieves that:
Sub Populate_entity()
' Declare 2 range variables (top row to copy from and paste destination)
Dim RowRange As Range
Dim PasteCells As Range
' Use the With block to specify the sheet. If you want the destination
' to be another sheet, then you can specify that instead:
' ThisWorkbook.Sheets("SheetName").Range("...")
With ThisWorkbook.ActiveSheet
Set RowRange = .Range("E1:DU1") ' Set range to copy from
Set PasteCells = .Range("C2:C1205") ' Set paste cells, blocks of 1204 cells in column C
End With
' Loop through RowRange, copy each cell's value into PasteCells
' Then offset the PasteCells range by 1024 rows, so next RowRange cell
' is inserted underneath previously copied cells.
Dim ofst As Long
For ofst = 1 To RowRange.Cells.Count
' Use .Value to avoid the (comparably slow) copy/paste operation
PasteCells.Offset((ofst - 1) * 1204, 0).Value = RowRange.Cells(ofst).Value
Next ofst
End Sub
In my opinion you don't need any search because your code always places the SearchString in row 1205. Since you know that it is there you don't need to look for it. This thought brings me to the code below.
Sub Populate_Entity()
Dim C As Long ' Column
Dim Target As Range
Dim FirstRow As Long
Dim LastRow As Long
FirstRow = 2
LastRow = 7 '1205
C = 3
Range("C2").value = Range("E1").value
' Cells(2, C).Value = Cells(1, 5).Value
Do
Set Target = Range(Cells(FirstRow, C), Cells(LastRow, C))
Target.FillDown
C = C + 1
Cells(2, C).value = "Can't figure"
Loop While C < 3 ' 122
End Sub
I have cut the loop short to only 7 rows (instead of 1205) and 3 columns (instead of 122). I just couldn't figure out where the text in the FirstRow should come from. For column C it comes from E1, but where does it come from in the subsequent columns? You can fill this in using the method I showed you above, like, Cells(2, C).Value = Cells(1, 5).Value. I believe that the 5 can be replaced by a value derived from the current C, perhaps C + 2.
Note the Cells(2, C).Value doesn't refer to the value in cell C2. Instead if refers to the cell in Row 2, Column C.
I am working on 2 different sheets which are Sheet1 and Sheet2.
Right now, I have managed to combined 2 sheet if the column header in both files is the same. So how to merge into a combined file which select specific column.
The problem I have right now is the header between 2 sheet is different so it is hard for me to merge 2 different header but it contains same type of data. For example Sheet1 use First Name as its column header and Sheet2 uses Nickname as its column header.
I also don't want it copy the entire column since it contain insignificant column to merged.
I attach the expected result for reference.
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
If you know what Columns your data is in then you can work with Sheets/Columns with simple Do Until Loop
See Example / and see comment on the code
Option Explicit
Public Sub Example()
Dim B As Range, _
C As Range, _
D As Range, _
E As Range, _
F As Range, _
G As Range ' Columns on Sheet1 & Sheet2
Dim i%, x% ' Dim as long
Dim Sht As Worksheet ' Every Sheet on This Workbook
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
i = 2 ' Start on row 2 - Sheet1 & Sheet2
x = 2 ' Start on row 2 - Combine sheet
'Looping through the worksheets in the workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine"
If Sht.Name <> "Combine" Then
Debug.Print Sht.Name ' Print on Immediate Window
Set B = Sht.Columns(2)
Set C = Sht.Columns(3)
Set D = Sht.Columns(4)
Set E = Sht.Columns(5)
Set F = Sht.Columns(6)
Do Until IsEmpty(B.Cells(i))
Comb.Columns(1).Cells(x).Value = B.Cells(i).Value
Comb.Columns(2).Cells(x).Value = C.Cells(i).Value
Comb.Columns(3).Cells(x).Value = D.Cells(i).Value
Comb.Columns(4).Cells(x).Value = E.Cells(i).Value
Comb.Columns(5).Cells(x).Value = F.Cells(i).Value
i = i + 1
x = x + 1
Loop
End If
i = 2 ' Reset 1st Loop
Next
' Auto-Fit Rows & Columns
With Comb.Cells
.Rows.AutoFit
.Columns.AutoFit
End With
End Sub
See also examples on copy/paste - values = values - PasteSpecial method
Also see How to avoid using Select in Excel VBA macros
I have added to your code and commented it. I hope this helps.
Sub Combine()
Dim J As Integer
Dim Rng As Range ' specify a range to copy
Dim R As Long ' set a variable to calculate a row number
' On Error Resume Next ' You want to see the errors and fix them
' therefore don't suppress them
' Sheets(1).Select ' you don't need to "select" anything
' Worksheets.Add ' instead of adding a sheet I suggest you
' you create a copy of Shhet(1)
Sheets("Sheet1").Copy Before:=Sheets(1)
' the new sheet will now be the "ActiveSheet"
With ActiveSheet
.Name = "Combined"
' delete all the columns you don't want to keep, like:-
.Columns("C:K").Delete ' or .Columns("F").Delete
' if you delete individual columns, delete from right to left (!!)
End With
' this part is already done
' Sheets(2).Activate ' you don't need to select anything
' Range("A1").EntireRow.Select
' Selection.Copy Destination:=Sheets(1).Range("A1")
' Note that sheets are numbered 1 and up.
' Therefore the newly inserted sheet is now # 1
' and the previous #1 is now Sheet(2)
For J = 3 To Sheets.Count
' Sheets(J).Activate ' you don't need to activate anything
' Range("A1").Select ' you don't need to select anything either
' Selection.CurrentRegion.Select ' the Selection is already selected
With Sheets(J)
' Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' It appears that you want to select the range from A2 to lastrow in A -1
R = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, "A"), .Cells(R - 1, "A"))
' avoid using the Selection object. Use Range object instead:-
' Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Rng.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
End With
Next J
End Sub
Note that you can copy a range comprising several columns in one operation. Just change the definition of the range you copy. This will copy columns A:E.
Set Rng = .Range(.Cells(2, "A"), .Cells(R - 1, "E"))
No other change is required.
Sub attempt()
'
' attempt Macro
'
'
For i = 0 To 818
Sheets("hedz").Select
q = (i * 4) + 1
ActiveSheet.Range(Cells(1, q), Cells(1, q + 3)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A" & i + 1).Select
ActiveSheet.Paste
Sheets("hedz").Select
I need help repeating this for 53 rows and restart pasting every 818th row in column A on sheet1. I already accomplished this through repeating the macro 53 times but I am just a beginner and could not figure out how. A copy of my spreadsheet:
This should do it:
Sub attemp()
Dim i&, j&
Dim ows As Worksheet, tws As Worksheet
Set ows = Sheets("hedz") 'Change to the sheet that has the data
Set tws = Sheets("Sheet1") 'change to the sheet where the data goes
With ows
'this loop finds the extents of the rows and iterates
For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
'this loop finds the extents of the columns and iterates.
'the step 4 jumps to every forth.
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 4
'this takes assigns the value of the four cells to the new sheet.
tws.Cells(tws.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4).Value = .Cells(i, j).Resize(, 4).Value
Next j
Next i
End With
End Sub
You need two loops. This will find the total columns and total rows.
I am a total n00b when it comes to excel and vba.
Any help would be much appreciated.
There is data from a to k in excel.
I am trying to:
Check whether E>2, to export G(x), E(x), and J(x) for all lines (columns) where this is the case.
I can't manage to select properly, and joins this with conditional successfully.
In addition, my pasting is super random.
I am trying to export it to a given filename # place, but haven't really gotten that far because cannot event export properly to different sheet in same workbook.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim Value As Range
Dim Copyarea1 As Range
Dim Copyarea2 As Range
Dim Copyarea3 As Range
Dim Copymaster As Range
Dim Pastesheet As Range
Sheet4.Activate
sheet1.Activate
Set Copyarea1 = sheet1.Range("F2")
Set Copyarea2 = sheet1.Range("H2")
Set Copyarea3 = sheet1.Range("I2")
Set Copymaster = Union(Copyarea1, Copyarea2, Copyarea3)
sheet1.Select
For Each Value In Range(["H2:H2539"])
If Value > 2 Then
Value.Select
Selection.Copy
Else: ActiveCell.Offset(1, 0).Activate
End If
If Value = "" Then Exit Sub
Sheet4.Select
Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(1, 0).Activate
sheet1.Activate
Next
Application.ScreenUpdating = True
End Sub
When I replace Value with copy master I get correct initial selection but fail at offsetting. and the export part is no good.
Only values to be copied, cells have formulas.
This code at first counts rows in workbook Book2.xlsm sheet1 and then go through all cells in original workbook range H2:H2539. If value is more then 2 then values from this row in columns F, H and I are pasted in A, B, C row in workbook Book2.xlsm sheet1 in first empty row.
Private Sub CommandButton1_Click()
Workbooks.Open Filename:="C:\Users\User\Desktop\Book2.xlsm" 'change path to your workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ThisWorkbook.Sheets("sheet1")
Set sh2 = Workbooks("Book2.xlsm").Sheets("sheet1")
Application.ScreenUpdating = False
'counts rows in sheet2 column A (this is where values are going to be copied)
If IsEmpty(sh2.Range("A1").End(xlDown)) = True Then
y = 1
Else
y = sh2.Range("A1", sh2.Range("A1").End(xlDown)).Rows.Count + 1
End If
For i = 2 To 2539 'number of rows in your range (sheet1)
If sh1.Cells(i, 8) > 2 Then
sh2.Cells(y, 1) = sh1.Cells(i, 8).Offset(0, -2)
sh2.Cells(y, 1).Offset(0, 1) = sh1.Cells(i, 8)
sh2.Cells(y, 1).Offset(0, 2) = sh1.Cells(i, 8).Offset(0, 1)
y = y + 1
ElseIf sh1.Cells(i, 8) = "" Then: Exit Sub
End If
Next i
Application.ScreenUpdating = True
Workbooks("2.xlsm").Close savechanges:=True 'closes your second workbook and save changes
End Sub
I am facing some difficulty in achieving the desired result for my macro.
Intention:
I have a list of data in sheets(input).column A (the number of rows that has value will vary and hence I created a loop that will run the macro until the activecell is blank).
My macro starts from Range(A2) and stretches all the way down column A, it stops only when it hits a blank row
Desired result for the macro will be to start copying the cell value in sheet(input).Range(A2) paste it to sheet(mywork).Range(B2:B6).
For example, if "Peter" was the value in cell sheet(input),range(A2) then when the marco runs and paste the value into sheet(mywork) range(B2:B6). ie range B2:B6 will reflect "Peter"
Then the macros loop back to sheet(input) & copy the next cell value and paste it to range(B7:B10)
Example: "Dave" was the value in sheet(input) Range(A3), then "Dave" will be paste into the next 4 rows in sheet(mywork).Range(B7:B10). B7:B10 will reflect "Dave"
Again repeating the same process goes back to sheet(input) this time range(A4), copys the value goes to sheet(mywork) and paste it into B11:B15.
Basically the process repeats....
The macro ends the when the activecell in sheet(input) column A is empty.
Sub playmacro()
Dim xxx As Long, yyy As Long
ThisWorkbook.Sheets("Input").Range("A2").Activate
Do While ActiveCell.Value <> ""
DoEvents
ActiveCell.Copy
For xxx = 2 To 350 Step 4
yyy = xxx + 3
Worksheets("mywork").Activate
With ActiveSheet
.Range(Cells(xxx, 2), Cells(yyy, 2)).PasteSpecial xlPasteValues
End With
Next xxx
ThisWorkbook.Sheets("Input").Select
ActiveCell.Offset(1, 0).Activate
Loop
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Dim Z As Long
Dim Cellidx As Range
Dim NextRow As Long
Dim Rng As Range
Dim SrcWks As Worksheet
Dim DataWks As Worksheet
Z = 1
Set SrcWks = Worksheets("Sheet1")
Set DataWks = Worksheets("Sheet2")
Set Rng = EntryWks.Range("B6:ad6")
NextRow = DataWks.UsedRange.Rows.Count
NextRow = IIf(NextRow = 1, 1, NextRow + 1)
For Each RA In Rng.Areas
For Each Cellidx In RA
Z = Z + 1
DataWks.Cells(NextRow, Z) = Cellidx
Next Cellidx
Next RA
End Sub
Alternatively
Worksheets("Sheet2").Range("P2").Value = Worksheets("Sheet1").Range("L10")
This is a CopynPaste - Method
Sub CopyDataToPlan()
Dim LDate As String
Dim LColumn As Integer
Dim LFound As Boolean
On Error GoTo Err_Execute
'Retrieve date value to search for
LDate = Sheets("Rolling Plan").Range("B4").Value
Sheets("Plan").Select
'Start at column B
LColumn = 2
LFound = False
While LFound = False
'Encountered blank cell in row 2, terminate search
If Len(Cells(2, LColumn)) = 0 Then
MsgBox "No matching date was found."
Exit Sub
'Found match in row 2
ElseIf Cells(2, LColumn) = LDate Then
'Select values to copy from "Rolling Plan" sheet
Sheets("Rolling Plan").Select
Range("B5:H6").Select
Selection.Copy
'Paste onto "Plan" sheet
Sheets("Plan").Select
Cells(3, LColumn).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
LFound = True
MsgBox "The data has been successfully copied."
'Continue searching
Else
LColumn = LColumn + 1
End If
Wend
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
And there might be some methods doing that in Excel.