The last two days I've been trying to get the resize vba to work.
I need 3 columns (Q,R,S) to be copied and pasted after column 19. This has to happen until the number of 3 column sets (i, copies of Q:S) is equal to the value in cell ("C18"), likewise, if the number of repeats of QRS is greater than the value in C18 the unnecessary copies should be deleted.
The resize worked fine when it was just one column but now that I try to get a set of 3 added or deleted it goes wrong..the number of copies is not equal to the value in ("C18") and the number of copies made or deleted is not constant when I rerun the sub.
Does anyone have a solution?
Sub resize()
Dim SLastCol As Long
Dim i As Long
i = Range("C18").Value * 3
SLastCol = Cells(1, Columns.Count).End(xlToLeft).Column - 19
If SLastCol < i Then
Columns("Q:S").EntireColumn.copy
Columns("T").EntireColumn.Resize(, Abs(SLastCol - i)).Insert shift:=xlToRight
ElseIf SLastCol > i Then
Columns("T:W").EntireColumn.Resize(, Abs(SLastCol - i)).Delete shift:=xlToLeft
End If
Application.CutCopyMode = False
End Sub
Please, test the next code. It will copy all columns in the range colsRng, as many times as is written in "C8":
Sub resizeColumnsCopy()
Dim i As Long, colsRng As Range, lastCol As Long, rngDel As Range, arrCols, arrPrevCols
'identify the previous processed columns and delete them, if any
lastCol = cells(1, Columns.count).End(xlToLeft).Column
arrPrevCols = Range(cells(1, 20), cells(1, lastCol)).Value 'place the headers after column 20 in an array
arrCols = Range("Q1:S1").Value 'do the same with the copied columns headers
For i = 1 To UBound(arrPrevCols, 2) Step 3 'iterate in the larger array, from three to three columns
If arrPrevCols(1, i) = arrCols(1, 1) Then 'finding the first column header
If rngDel Is Nothing Then
Set rngDel = Range(cells(1, 19 + i), cells(1, 19 + i + 2)) 'create a range of the three involved columns
Else
Set rngDel = Union(rngDel, Range(cells(1, 19 + i), cells(1, 19 + i + 2))) 'careate a Union between the previous range and the next three
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete 'if cases of processed columns found, then delete the columns
i = Range("C18").Value
Set colsRng = Columns("Q:S")
colsRng.Copy
cells(1, colsRng.Column + colsRng.Columns.count).EntireColumn.resize(, i * colsRng.Columns.count).Insert Shift:=xlToRight
Application.CutCopyMode = False
End Sub
But, please edit your question and explain about the necessity of previous processed columns deletion. Otherwise, somebody else looking to my code will think that I recently hit my head...
Related
Hi Hopefully somebody can help as i am missing something in my code.
I am trying to loop through a dynamic row from the last knowing value to the new values, then add these new values as a column headr in starting in row 3.
I have the first portion and can get the new values to paste into next blank column. the issue is i can't work out how to offset to the next empty cell. rather than pasting all new values into the same cell.
Sub Testnewname()
Dim Nw2 As Integer
Dim c As Long
Dim D As Long
Dim Lcol1 As Long
Dim Lrow2 As Long
Lcol1 = Cells(3, Columns.Count).End(xlToLeft).Column '' Find last column available in row 3
Lrow2 = Cells(Rows.Count, 10).End(xlUp).Row ''Find last row where new info is put via a table defined by names =UNIQUE(Table1[[#Data],[Company]],FALSE,FALSE)
Nw2 = Sheets("Cost Table").Range("$H$10").Value ''value of the old number of cells used to start from in loop
c = Lcol1 + 1 ''allocate a varable to last column + 1
For D = Nw2 To Lrow2 ''for d (i) from cell 19 to last cell
Cells(D, 10).Copy 'copy cell value
Cells(3, c).PasteSpecial xlPasteValues ''this is where is would of thought pasteinto last column whichit does. What seems to happen is id doesnt move to next column when it reloops
Next D ''would of expected that when it goes onto next loop that the C (Lcol+1) would recalculate
ThisWorkbook.Worksheets("Cost Table").Range("H11").Copy
ThisWorkbook.Worksheets("Cost Table").Range("H10").PasteSpecial Paste:=xlPasteValues ' takes the value from a CountA function in H11 and pastes into H10 to update the last place a cell value was prior to running macro and updates Nw2 for running the macro again
Application.CutCopyMode = False
End Sub
I have tried to add in a Second loop for the column but this does nothing
For C = Lcol to Lcol + 1
For D = Nw2 To Lrow2
Cells(D, 10).Copy
Cells(3, c).PasteSpecial xlPasteValues
Next D
Next C
Any help greatly appreciated
cheers
You should be able to do this without using a loop, or copy/paste:
Sub Testnewname()
Dim Nw2 As Long, ws As Worksheet, wsCostTbl As Worksheet, cDest As Range
Set ws = ActiveSheet 'or some other specific sheet
Set wsCostTbl = ThisWorkbook.Worksheets("Cost Table")
'next empty cell on row 3
Set cDest = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Offset(0, 1)
'starting row# for copy
Nw2 = Sheets("Cost Table").Range("$H$10").Value
'using the source range...
With ws.Range(ws.Cells(Nw2, 10), ws.Cells(Rows.Count, 10).End(xlUp))
'...transfer the values, flipping rows and columns using Transpose
cDest.Resize(.Columns.Count, .Rows.Count).Value = Application.Transpose(.Value)
End With
wsCostTbl.Range("H10").Value = wsCostTbl.Range("H11").Value
End Sub
Hi thank you both for that, I have tested both ways and work for the life of me couldn't work out the possion of the C=C+1.
Tim i really like this with out looping i did try something like this as i have another script that i removed looping from as itwas so much quiker.
With ws.Range(ws.Cells(Nw2, 10), ws.Cells(Rows.Count, 10).End(xlUp))
'...transfer the values, flipping rows and columns using Transpose
cDest.Resize(.Columns.Count, .Rows.Count).Value = Application.Transpose(.Value)
End With
Is a new one for me and will be very useful in anumber of toold i am createing thank you for this
I've been running this script for a while with not issues, and then today it broke. It's very basic as in I'm just filtering values from one tab and then copying and pasting them onto another tab in the top row. Suddenly though, it will paste the values and then repeat paste the values 19 more times for a total of 20 copy pastes.
Sheets("BSLOG").Select
Range("Q1").Select
Selection.AutoFilter Field:=17, Criteria1:="1"
Range("A1:Q5000").Select
Range("A1:Q5000").Activate
Selection.Copy
Sheets("PENDG TRADES").Select
Range("A1:Q300").Select
ActiveSheet.Paste
Try the next code, please. No need to select, activate anything. In this case, these selections do not bring any benefit, they only consume Excel resources:
Sub testFilterCopy()
Dim shB As Worksheet, shP As Worksheet
Set shB = Sheets("BSLOG")
Set shP = Sheets("PENDG TRADES")
shB.Range("Q1").AutoFilter field:=17, Criteria1:="1"
shB.Range("A1:Q5000").Copy shP.Range("A1")
End Sub
If you want to make the range dynamic (in terms of rows) I can show you how to initially calculate the existing number of rows and set the range to be copied according to it.
FaneDuru is right.
You can also try this code, which I prefer more:
Option Base 1 'This means all array starts at 1. It is set by default at 0. Use whatever you prefer,depending if you have headers or not, etc
Sub TestFilter()
Dim shBSLOG As Worksheet
Dim shPENDG As Worksheet
Dim rngBSLOG As Range
Dim arrBSLOG(), arrCopy()
Dim RowsInBSLOG&
Dim i&, j&, k&
Set shBSLOG = Worksheets("BSLOG")
Set shPENDG = Worksheets("PENDG TRADES")
With shBSLOG
Set rngBSLOG = .Range(.Cells(1, 1), .Cells(5000, 17))
End With
RowsInBSLOG = rngBSLOG.Rows.Count
arrBSLOG = rngBSLOG
ReDim arrCopy(1 To RowsInBSLOG, 1 To 17) 'set the size of the new array as the original array
k = 1 'k is set to 1. This will be used to the row of the new array "arrCopy"
For i = 1 To RowsInBSLOG 'filter the array. From the row "i" = 1 to the total of rows "RowsinBSLOG
If arrBSLOG(i, 1) = 1 Then 'if the first column of the row i is equal to 1, then...
For j = 1 To 17
arrCopy(k, j) = arrBSLOG(i, j) 'copy the row
Next j
k = k + 1 'next copy will be in a new row
End If
Next i 'repeat
With shPENDG
.Range(.Cells(1, 1), .Cells(k, 17)) = arrCopy() 'place the new array in the new sheet
End With
End Sub
what i want to do is to delete rows if there are 2 consecutive empty rows and also to have the empty rows between the header and the first set of data row to be deleted as well.This is my original
input and what i want to have is this. i have tried to find some codes here and there and come up with this code.
Sub Testing()
Dim i As Long , lRow As Long
Dim ws As Worksheet
Set ws = Activesheet
With ws
With .Range("C:C")
fr = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlValues).row
If fr > 2 Then
.Rows("2:" & fr - 1).EntireRow.Delete
End If
End With
i = 1
For i = 1 To lRow
If IsEmpty(Cells(i, 3)) And IsEmpty(Cells(i + 1, 3)) Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
However, there are still some consecutive empty rows in the middle of the data set. I know that is because i am increasing i which will look at the next cell but i am not sure how to solve it. I am new to vba and even newer to SO posting so let me know if there is anything i am doing wrong and thank you for your help.
The only thing you need to do is looping backwards. Instead of
For i = 1 To lRow
do
For i = lRow To 1 Step -1
This is because looping from the bottom doesn't have any influence on the row counting of the not yet processed rows, but looping top to bottom does.
Also you can skip i = 1 right before For it doesn't have any influence since For starts with whatever i is specified as lower bound.
I think your code is just an example but just in case note that lRow is never set to a value in your code and therefore is 0.
Note that in this line
If IsEmpty(Cells(i, 3)) And IsEmpty(Cells(i + 1, 3)) Then
your Cells objects are not referenced to the sheet of the With statement because you forgot the . in the beginning. It should be
If IsEmpty(.Cells(i, 3)) And IsEmpty(.Cells(i + 1, 3)) Then
Furthermore I highly recommend that if you use the Range.Find method
fr = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlValues).row
that you always specify the LookAt parameter as xlWhole or xlPart (see XlLookAt). Because the the LookAt parameter has no default value (sadly) and if you don't specify it, VBA will use either xlWhole or xlPart whatever was used last by either the user interface or VBA. So you cannot know which one was used before and it will become pretty random (or your code might sometimes work and sometimes not).
Alternative (much faster) approach …
… is to keep the forward loop and collect all rows to delete in a variable RowsToDelete to delete them in the end at once. It is so much faster because every delete action takes time and in this approach you only have one delete action … versus one delete action per row in the other approach.
Dim RowsToDelete As Range
For i = 1 To lRow 'forward loop is no issue here because we just collect
If IsEmpty(.Cells(i, 3)) And IsEmpty(.Cells(i + 1, 3)) Then
If RowsToDelete Is Nothing Then 'first row
Set RowsToDelete = .Rows(i).EntireRow
Else 'append more rows with union
Set RowsToDelete = Application.Union(RowsToDelete, .Rows(i).EntireRow)
End If
End If
Next i
'delete all collected rows (after the loop, so delete doesn't affect row counting of the loop)
If Not RowsToDelete Is Nothing Then
RowsToDelete.Delete
End If
I think you need to decrease i after deleting a row.
For i = 1 To lRow
If IsEmpty(Cells(i, 3)) And IsEmpty(Cells(i + 1, 3)) Then
.Rows(i).EntireRow.Delete
i = i - 1
lRow = lRow - 1
End If
If i > lRow Then Exit For
Next i
Dim blankCtr As Integer
blankCtr = 0
With ActiveSheet
For i = .Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
blankCtr = blankCtr + 1
If .Rows(i).Cells(1).End(xlUp).Row = 1 Then
.Rows(i & ":" & .Rows(i).Cells(1).End(xlUp).Offset(1).Row).Delete
Exit Sub
End If
If blankCtr > 1 Then
.Rows(i).Delete
blankCtr = blankCtr - 1
End If
Else
blankCtr = 0
GoTo here
End If
here:
Next i
End With
I have a rather large sheet (approx 60K rows by 50 cols). I'm trying to copy several (2 to 8) rows into clipboard and then insert copied cells. This operation takes more than a minute to complete!
I've tried disabling automatic calculations, initiating this operation from VBA, like this:
Range("A1").Insert xlShiftDown
to no available. If I paste (Ctrl-V) rather than insert it works like a snap.
Any ideas how to work around this issue?
Since you can paste the data quickly enough use that instead of inserting, then sort the rows:
In an empty column on the first row of data type the number of rows you want to insert plus 1 (e.g. to insert 3 rows type 4)
Add the next number in the next row, then select both cells and autocomplete the column so that each row has an increasing number
Paste the new data at the end of the old data, immediately after the last row
Number the first row pasted as 1, the 2nd as 2 etc
Sort the sheet ascending on the number column then delete the column
I implemented Absinthe's algorithm, here's the code:
Sub InsertRows()
Dim SourceRange, FillRange As Range
Dim LastCol, LastRow, ActRow, CpdRows As Long
Dim i As Integer
If Application.CutCopyMode <> xlCopy Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
With ActiveSheet
LastCol = .UsedRange.Columns.Count
LastRow = .UsedRange.Rows.Count
ActRow = ActiveCell.Row
.Paste Destination:=.Cells(LastRow + 1, 1)
CpdRows = .UsedRange.Rows.Count - LastRow
Application.Calculation = xlCalculationManual
Set SourceRange = .Range(.Cells(ActRow, LastCol + 1), .Cells(ActRow + 1, LastCol + 1))
SourceRange.Cells(1).Value = CpdRows + 1
SourceRange.Cells(2).Value = CpdRows + 2
Set FillRange = .Range(.Cells(ActRow, LastCol + 1), .Cells(LastRow, LastCol + 1))
SourceRange.AutoFill Destination:=FillRange
For i = 1 To CpdRows
.Cells(LastRow + i, LastCol + 1).Value = i
Next i
.Range(.Cells(ActRow, 1), .Cells(LastRow + CpdRows, LastCol + 1)).Sort Key1:=.Cells(ActRow, LastCol + 1), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlTopToBottom
.Columns(LastCol + 1).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
It's works definitely faster than "insert copied cells" and it seems it's accelerating after the 1st use (I mean, when I run the macro for the 2nd, 3rd etc time it works even faster than on the 1st run). There are the cons, too. For example, named ranges do not automatically expand when you insert the lines in this manner.
And the most significant problem of this method: Excel does not move the borders with the cells when sorting. Therefore, the border structure will be ruined. The only workaround I know of is to use conditional formatting for the borders.
This all being said, it's a good workaround
I'm looking for a way to copy a range of cells, but to only copy the cells that contain a value.
In my excel sheet I have data running from A1-A18, B is empty and C1-C2. Now I would like to copy all the cells that contain a value.
With Range("A1")
Range(.Cells(1, 1), .End(xlDown).Cells(50, 3)).Copy
End With
This will copy everything from A1-C50, but I only want A1-A18 and C1-C2 to be copied seen as though these contain data. But it needs to be formed in a way that once I have data in B or my range extends, that these get copied too.
'So the range could be 5000 and it only selects the data with a value.
With Range("A1")
Range(.Cells(1, 1), .End(xlDown).Cells(5000, 3)).Copy
End With
Thanks!
Thanks to Jean, Current code:
Sub test()
Dim i As Integer
Sheets("Sheet1").Select
i = 1
With Range("A1")
If .Cells(1, 1).Value = "" Then
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("A" & i)
x = x + 1
End If
End With
Sheets("Sheet1").Select
x = 1
With Range("B1")
' Column B may be empty. If so, xlDown will return cell C65536
' and whole empty column will be copied... prevent this.
If .Cells(1, 1).Value = "" Then
'Nothing in this column.
'Do nothing.
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("B" & i)
x = x + 1
End If
End With
Sheets("Sheet1").Select
x = 1
With Range("C1")
If .Cells(1, 1).Value = "" Then
Else
Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("C" & i)
x = x + 1
End If
End With
End Sub
A1 - A5 contains data, A6 is blanc, A7 contains data. It stops at A6 and heads over to column B, and continues in the same way.
Since your three columns have different sizes, the safest thing to do is to copy them one by one. Any shortcuts à la PasteSpecial will probably end up causing you headaches.
With Range("A1")
Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeA
End With
With Range("B1")
' Column B may be empty. If so, xlDown will return cell C65536
' and whole empty column will be copied... prevent this.
If .Cells(1, 1).Value = "" Then
'Nothing in this column.
'Do nothing.
Else
Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeB
EndIf
End With
With Range("C1")
Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeC
End With
Now this is ugly, and a cleaner option would be to loop through the columns, especially if you have many columns and you're pasting them to adjacent columns in the same order.
Sub CopyStuff()
Dim iCol As Long
' Loop through columns
For iCol = 1 To 3 ' or however many columns you have
With Worksheets("Sheet1").Columns(iCol)
' Check that column is not empty.
If .Cells(1, 1).Value = "" Then
'Nothing in this column.
'Do nothing.
Else
' Copy the column to the destination
Range(.Cells(1, 1), .End(xlDown)).Copy _
Destination:=Worksheets("Sheet2").Columns(iCol).Cells(1, 1)
End If
End With
Next iCol
End Sub
EDIT
So you've changed your question... Try looping through the individual cells, checking if the current cell is empty, and if not copy it. Haven't tested this, but you get the idea:
iMaxRow = 5000 ' or whatever the max is.
'Don't make too large because this will slow down your code.
' Loop through columns and rows
For iCol = 1 To 3 ' or however many columns you have
For iRow = 1 To iMaxRow
With Worksheets("Sheet1").Cells(iRow,iCol)
' Check that cell is not empty.
If .Value = "" Then
'Nothing in this cell.
'Do nothing.
Else
' Copy the cell to the destination
.Copy Destination:=Worksheets("Sheet2").cells(iRow,iCol)
End If
End With
Next iRow
Next iCol
This code will be really slow if iMaxRow is large. My hunch is that you're trying to solve a problem in a sort of inefficient way... It's a bit hard to settle on an optimal strategy when the question keeps changing.
Take a look at the paste Special function. There's a 'skip blank' property that may help you.
To improve upon Jean-Francois Corbett's answer, use .UsedRange.Rows.Count to get the last used row. This will give you a fairly accurate range and it will not stop at the first blank cell.
Here is a link to an excellent example with commented notes for beginners...
Excel macro - paste only non empty cells from one sheet to another - Stack Overflow