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.
Related
I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft
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.
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
I need to be able to look at a specified range of cells in every worksheet of my workbook and if they meet criteria, copy that row to a summary sheet. The below code works for the most part except there are a few instances where it copies rows that do not meet the criteria and one instance where it skips a row it should have copied.
Is there a way to use a debug tool so that at any time while cycling through the code I can see: What is the active sheet? What is the active cell? What is the active row? etc.
Also, should I use a -For Each Cell in Range- instead of -While Len- to loop through the specified range on each sheet?
Sub LoopThroughSheets()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim ws As Worksheet
'Start copying data to row 2 in HH (row counter variable)
LCopyToRow = 2
For Each ws In ActiveWorkbook.Worksheets
'Start search in row 7
LSearchRow = 7
While Len(ws.Range("M" & CStr(LSearchRow)).Value) > 0
'If value in column M > 0.8, copy entire row to HH
If ws.Range("M" & CStr(LSearchRow)).Value > 0.8 Then
'Select row in active Sheet to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into HH in next row
Sheets("HH").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to active ws to continue searching
ws.Activate
End If
LSearchRow = LSearchRow + 1
Wend
Next ws
'Position on cell A1 in sheet HH
Sheets("HH").Select
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
End Sub
Very similar to the previous answer just worded differently.Same results though.
Sub Button1_Click()
Dim Rws As Long, Rng As Range, ws As Worksheet, sh As Worksheet, c As Range, x As Integer
Set ws = Worksheets("HH")
x = 2
Application.ScreenUpdating = 0
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
Rws = .Cells(Rows.Count, "M").End(xlUp).Row
Set Rng = .Range(.Cells(7, "M"), .Cells(Rws, "M"))
For Each c In Rng.Cells
If c.Value > 0.8 Then
c.EntireRow.Copy Destination:=ws.Cells(x, "A")
x = x + 1
End If
Next c
End With
End If
Next sh
End Sub
For your first question about debugging, you can use:
Debug.Print "Worksheet: " & ActiveSheet.Name
at any time in your code to print out which sheet you are on into the "Immediate" window in the Visual Basic Editor. This is great for debugging in all scenarios.
Second, a For Each loop is the fastest way to loop through anything but it has disadvantages. Namely, if you are deleting/inserting anything it will return funny results (Copy/Paste will be ok). Any sort of While loop is better to use if you don't have a predetermined idea of how many rows you are going to need to work through.
As far as your code is concerned this is how I would do it (you would still need to include your code above and below the while loop):
Dim Items As Range
Dim Item As Range
'This will set the code to loop from M7 to the last row, if you
'didn't want to go to the end there is probably a better way to do it.
Set Items = ws.Range("M7:M26")
For Each Item In Items
'If value in column M > 0.8, copy entire row to HH
If Item.Value > 0.8 Then
'Select row in active Sheet to copy
Item.EntireRow.Copy
'Paste row into HH in next row
Sheets("HH").Rows(LCopyToRow & ":" & LCopyToRow).PasteSpecial
'Move counter to next row
LCopyToRow = LCopyToRow + 1
End If
Next Item