I am running the below VBA code -
lastColumn = Cells(5, Columns.count).End(xlToLeft).Column
count_dates = Range("H2").Value
Set cellSource = Range(Cells(6, 13).Address)
Set cellTarget = Range(Cells(6, 13), Cells(count_dates + 5, lastColumn))
cellSource.AutoFill Destination:=cellTarget, Type:=xlFillDefault
The code is running perfectly fine on one PC (Excel 2016), but not running on the other (Excel 2010). I am unable to figure out the reason for the same.
The cell (6,13) has a formula which i want to drag both horizontally right and vertically down
The error I get is -
Error 1004 : Autofill method of range class failed
In Excel 2010 Autofill works in a single direction only, either horizontal or vertical. Therefore, if you wish to fill a 2-dimensional range you should first fill one row horizontally (including the source cell) and then use that row as source copy the entire row down. The code below does that.
Sub AutoFillRange()
Dim lastColumn As Long
Dim count_Dates As Long
Dim cellSource As Range, cellTarget As Range
lastColumn = Cells(5, Columns.Count).End(xlToLeft).Column
count_Dates = Range("H2").Value
Set cellSource = ActiveSheet.Cells(6, "M")
If lastColumn <> cellSource.Column Then
' return an unexpected result if lastColumn is smaller than cellSource.Column
Set cellTarget = cellSource.Resize(1, Abs(lastColumn - cellSource.Column + 1))
cellSource.AutoFill Destination:=cellTarget, Type:=xlFillDefault
Set cellSource = cellTarget
End If
Set cellTarget = cellSource.Resize(count_Dates, cellSource.Columns.Count)
cellSource.AutoFill Destination:=cellTarget, Type:=xlFillDefault
End Sub
Related
Apologies in advance as I'm sure this is a simple question, and there's lots of similar answers out there, but I haven't been able to leverage them into a working solution.
My situation is I have an Excel file with 28 tabs. Each Sheet has data in the exact same format in range A1:N10000. Note though that some of the cells in each tab are blank. This holds true across every tab. I would like to have all 28 tabs merged into one new Sheet call Combined.
I have been trying to leverage this Macro:
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
Obviously I've encountered problems running this and the resulting data only has a few values pasted instead of the expected ~280,000 rows (28 tabs, 10k rows each). I suspect one of the reasons is because there are blank cells in the tabs, so this Macro isn't reading the data as I intend it to. How can I modify it just to copy A1:N10000 in each tab and paste each to the Combined tab? Also, will I hit issues with trying to populate a sheet with 280,000 rows?
Thank you!
David
CurrentRegion will not copy everything you want if there are blank cells, as you suspected. Also, it's preferable to avoid using Select - since you don't really need to select the cells before copying - and On Error Resume Next - this doesn't handle errors at all, it ignores them.
Option Explicit
Sub Combine()
Dim i As Integer
Dim combinedWs As Worksheet, ws As Worksheet
Dim copyRng As Range
Dim lastRow As Long
' Add combined worksheet and populate headers
Set combinedWs = Worksheets.Add(Before:=Sheets(1))
combinedWs.Name = "Combined"
Sheets(2).Rows(1).Copy combinedWs.Rows(1)
' Loop through rest of Sheets
For i = 2 To Sheets.Count
Set ws = Sheets(i)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set copyRng = Range(.Cells(2, 1), .Cells(lastRow, "N"))
copyRng.Copy combinedWs.Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
Next i
End Sub
If you want to copy a specific, hard-coded range, replace the code inside With ws... End With.
Set copyRng = Range(.Cells(2, 1), .Cells(10000, 14))
copyRng.Copy combinedWs.Cells(2, 1).Offset((i-2)*copyRng.Rows.Count)
A bit of a hack on the last line: for each iteration of i you are offsetting by the number of rows in copyRng. You start in combinedWs.Cells(2, 1), or A2. On the first iteration, i - 2 = 0, so there is no offset. On subsequent iterations, you offset 9999, 19998, and so on.
You can try the below code:
Sub Combine()
Dim cmbSheet, ws As Worksheet
Dim tmpIndex As Double
Set cmbSheet = ThisWorkbook.Worksheets.Add
cmbSheet.Name = "Combined"
tmpIndex = 0
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Combined" Then
If tmpIndex = 0 Then
cmbSheet.Cells(1, 1) = "Sheet Name"
ws.Range("A1:N1").Copy Destination:=cmbSheet.Cells(1, 2)
End If
ws.Range("A2:N10000").Copy Destination:=cmbSheet.Cells((tmpIndex * 10000) + 2 - tmpIndex, 2)
cmbSheet.Cells((tmpIndex * 10000) + 2, 1).Value = ws.Name
tmpIndex = tmpIndex + 1
End If
Next ws
End Sub
No matter what I do I can't get this error to go away. This current version of code is an effort to completely spell out each reference. I'm getting the error after the 'set range for BOM components' line. Most topics point out that using .Range(Cells()) without specifying where the cells are located will lead to this error, but I've done the complete overkill referencing so I'm not sure why it still errors out. Only one workbook here as well.
#Scott Craner #BruceWayne I figured it out finally; the Oracle report comes out in a pretty f****d up format, and the first sheet in the loop was causing the ranges to actually be unequal. As soon as I deleted that sheet it ran perfectly.
Sub Macro3()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+c
'
Dim ws As Worksheet
Dim lastRow As Integer
Dim summaryRow As Integer
Dim currentSheetRows As Integer
Dim i As Integer
Dim j As Integer
summaryRow = 2
For Each ws In ActiveWorkbook.Worksheets
If ws.Range("L3") = "" Then
currentSheetRows = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
i = summaryRow
j = summaryRow
'set range for item # and item UOM'
For j = summaryRow To (summaryRow + (currentSheetRows - 3))
Sheets("Summary").Cells(j, 1).Value = ws.Cells(2, 1).Value
Next j
For i = summaryRow To (summaryRow + (currentSheetRows - 3))
Sheets("Summary").Cells(i, 2).Value = ws.Cells(2, 1).Value
Next i
'set range for BOM components'
ThisWorkbook.Worksheets("Summary").Range(ThisWorkbook.Worksheets("Summary").Cells(summaryRow, 3), ThisWorkbook.Worksheets("Summary").Cells((summaryRow + (currentSheetRows - 3)), 6)).Value = ThisWorkbook.Worksheets(ws.Name).Range(ThisWorkbook.Worksheets(ws.Name).Cells(3, 6), ThisWorkbook.Worksheets(ws.Name).Cells(currentSheetRows, 9)).Value
summaryRow = summaryRow + currentSheetRows
End If
Next ws
End Sub
Woah - first, check that the ranges are equal sizes. Then, I highly suggest using some variables for your sheet names and ranges:
Sub t()
Dim summaryWS As Worksheet
Dim otherWS As Worksheet
Set summaryWS = ThisWorkbook.Sheets("Summary")
Set otherWS = ThisWorkbook.Worksheets(ws.Name)
Dim copyRng As Range, pasteRng As Range
With summaryWS
Set copyRng = .Range(.Cells(SummaryRow, 3), .Cells((SummaryRow + (currentSheetRows - 3)), 6))
End With
With otherWS
Set pasteRng = .Range(.Cells(3, 6), .Cells(currentSheetRows, 9))
End With
pasteRng.Value = copyRng.Value
End Sub
Does that help your issue?
You're using
ActiveWorkbook
To set the loop current sheet
and then
ThisWorkbook
in the copy/paste values statement that errors
It may then be the workbook you're running the macro from (ThisWorkbook) differs from the currently active one (ActiveWorkbook) whose worksheets you're looping through
In such a case just change ThisWorkbook to ActiveWorkbook
The problem is here:
ThisWorkbook.Worksheets("Summary").Range(ThisWorkbook.Worksheets("Summary").Cells(summaryRow, 3), ThisWorkbook.Worksheets("Summary").Cells((summaryRow + (currentSheetRows - 3)), 6)).Value = ThisWorkbook.Worksheets(ws.Name).Range(ThisWorkbook.Worksheets(ws.Name).Cells(3, 6), ThisWorkbook.Worksheets(ws.Name).Cells(currentSheetRows, 9)).Value
the subscript is out of range.
Try
With Sheets(ws.name)
.Cells({var},{var}).Value = {var}
I have the below code and it works perfectly for my purposes except when an AutoFilter is applied to the sheet & row 2 is hidden by the AutoFilter.
The Macro inserts the 'Record_Created_Year' and '=Year(##)' into the 1st empty Column & Row 1/2 correctly (even if the Row is hidden), however does not FillDown the calculations to the last row.
Instead of filling down the calculations added into Row 2, it is instead selecting the 2nd visible row (which could be Row 3) and filling down the values within those cells (which are blank, but for testing purposes I populated them to prove the theory).
I have been able to work around the issue by including a command "ActiveSheet.AutoFilterMode = False", however that is causing some issues for a subset of users who need to reapply complex filters after running the macro.
Is there a better way to define the FillDown Range, so it ignores the Auto Filter and actually Fills Down the data/calculations within Row2 rather than the data contained within the 2nd visible row?
Cheers in advance for any assistance.
Private Sub Add_and_Filldown_Calcs()
Dim LastCol As Long
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
Dim rng As Range
Set rng = ActiveSheet.Cells
Dim Created_Date As Range
Set Created_Date = ActiveSheet.Range("A1:BZ1").Find("sys_created_on", lookat:=xlWhole)
rng.Parent.Cells(1, LastCol + 1).Value = "Record_Created_Year"
rng.Parent.Cells(2, LastCol + 1).Formula = "=year(" & Replace(Created_Date.Address(False, False), "1", "") & "2)"
rng.Parent.Cells(1, LastCol + 2).Value = "Record_Created_Month"
rng.Parent.Cells(2, LastCol + 2).Formula = "=Month(" & Replace(Created_Date.Address(False, False), "1", "") & "2)"
' Many others removed to make it easier to read
'Filldown new calcs
Dim LastColAfterCalulations As Long
With ActiveSheet
lastcolaftercalculations = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Range(Cells(2, LastCol + 1), Cells(LastRow, lastcolaftercalculations)).FillDown
End Sub
A workaround could be to first copy the invisible row 2 to the visible row 3 end then fill Down. Something like:
Range(Cells(2, LastCol + 1),Cells(2,lastcolaftercalculations)).copy Range(Cells(3, LastCol + 1,Cells(2,lastcolaftercalculations))
Range(Cells(3, LastCol + 1), Cells(LastRow, lastcolaftercalculations)).FillDown
This does however not fill other filtered cells. When you want that you could use this code, that will first disable the autofilter and then reset it to the previous setting after you run your code.
I want to learn how to create a symmetric matrix in VBA. For example in the first step I want to choose Range("C3:I3") then copy to the Range("B4:B10"). In the second stage it should choose Range("D4:I4") then copy to the Range("C5:C10"). It should go on like that.
I have some code to do it. Your selected cell must be within the range of numbers.
1. If the diagonal line is empty.
►
The code:
Sub making_symmetric_matrix()
Dim i As Long, j As Long
Dim rng As Range
Set rng = Selection.CurrentRegion
Dim rngStart As Range
Set rngStart = Cells(rng.Row, rng.Column - 1)
For i = 1 To rng.Rows.Count
For j = i To rng.Columns.Count
rngStart.Offset(j, i - 1).Value = rngStart.Offset(i - 1, j).Value
Next
Next
End Sub
2. If the diagonal line is not empty.
►
The code:
Sub making_symmetric_matrix2()
Dim i As Long, j As Long
Dim rng As Range
Set rng = Selection.CurrentRegion
Dim rngStart As Range
Set rngStart = Cells(rng.Row, rng.Column)
For i = 1 To rng.Rows.Count
For j = i To rng.Columns.Count
rngStart.Offset(j - 1, i - 1).Value = rngStart.Offset(i - 1, j - 1).Value
Next
Next
End Sub
You don't need VBA to do that. Select the cells and copy them. Select the top cell of the target range, use Paste Special and tick the box for "Transpose".
If you really need VBA to do this, you definitely don't need a loop as suggested in the other post. Just use the transpose option in the VBA code. For a large data set this will be a lot faster than looping through each cell.
Range("C3:I3").Copy
Range("B4").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
The left() function (not Leftsub()) is NOT populating the destination range. What am I doing wrong? Thank you!!!
Sub LeftSub()
Dim SourceRange As Range, DestinationRange As Range, i As Integer, LastRow As Integer
Worksheets("JE_data").Activate
Range("J2").Activate
LastRow = Cells(Rows.count, "A").End(xlUp).row
'Define our source range:
Set SourceRange = Worksheets("JE_data").Range(Cells(2, 10), Cells(LastRow, 10))
'Define our target range where we will print.
'Note that this is expected to be of same shape as source
Set DestinationRange = Worksheets("JE_data").Range(Cells(2, 11), Cells(LastRow, 11))
'Iterate through each source cell and print left 30 characters in target cell
For i = 2 To SourceRange.count
DestinationRange(i, 11).Value = Left(SourceRange(i, 10).Value, 30)
Next i
End Sub
The error is here
Left(SourceRange(i, 10).Value, 30)
Already you have defined SourceRange as a Range of Cells
Set SourceRange = Worksheets("JE_data").Range(Cells(2, 10), Cells(LastRow, 10))
Again you are pointing using i, 10 gives you
.Range(Cells(2, 10), Cells(LastRow, 10))(i,10)
That points to the cell relative to upper left cell of your selection which means (2+i,10+10)th Cell (as (2,10) is your Upper left cell of selected Range) that doesn't work. Instead you can directly use this command
Left(Worksheets("JE_data").Cells(i,10).Value, 30)
And for DestinationRange As well
Worksheets("JE_data").Cells(i, 11).Value = Left(Worksheets("JE_data").Cells(i,10).Value, 30)
Hope this helps
Just from quickly looking at it - try replacing
DestinationRange(i, 11).Value = Left(SourceRange(i, 10).Value, 30)
with
DestinationRange(i, 1).Value = Left(SourceRange(i, 1).Value, 30)
When I want to find the last cell in a sheet, I use this:
llof = ActiveSheet.UsedRange.SpecialCells(xlLastCell).address
or
llof = ActiveSheet.UsedRange.SpecialCells(xlLastCell).row
the beauty of this command is that it re-sets the spreadsheet pointers so that any un-used space from adding and deleting lines are removed.