I have been working on a code that copy the last column and insert a new one, copying its formula and format. However, I need to delete the values of the cells from row 6 to 24 and then from 56 to 78 in the new column created. I couldn't find a way to refer to those cells in order to delete their values, could anyone help me on this? My code is below:
Sub Copy_Column()
Dim LastCol As Integer
With Worksheets("BO_Corretora")
LastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
Columns(LastCol).Copy
Columns(LastCol + 1).PasteSpecial Paste:=xlPasteFormats
Columns(LastCol + 1).PasteSpecial Paste:=xlPasteFormulas
End With
End Sub
You could use intersect. This keeps the rows to be deleted easy to read and you could store them in a constant for easy editing if required.
Sub Copy_Column()
Dim LastCol As Integer
Dim NewCol As String
With Worksheets("BO_Corretora")
LastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
.Columns(LastCol).Copy
.Columns(LastCol + 1).PasteSpecial Paste:=xlPasteFormats
.Columns(LastCol + 1).PasteSpecial Paste:=xlPasteFormulas
Intersect(.Columns(LastCol + 1), .Range("6:24,56:78")).ClearContents
End With
End Sub
Is this what you are trying?
Sub Copy_Column()
Dim LastCol As Integer
Dim NewCol As String
With Worksheets("BO_Corretora")
LastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
.Columns(LastCol).Copy
.Columns(LastCol + 1).PasteSpecial Paste:=xlPasteFormats
.Columns(LastCol + 1).PasteSpecial Paste:=xlPasteFormulas
'~~> Get the Column Letter of the new column
NewCol = Split(.Cells(, LastCol + 1).Address, "$")(1)
'~~> Range would be like Range("A6:A24,A56:A78")
.Range(NewCol & "6:" & NewCol & "24," & _
NewCol & "56:" & NewCol & "78").ClearContents
End With
End Sub
Related
I'm working on a excel document with multiple seperate data, all in a single column (A1 to A10160).
All the data begins in a cell with the text NC/xx/xxxx/x (x being variable) and ending in a cell containing different dates but the cell above it always has the text "Start Date". Some data covers 49 cells others cover 51 cells so it's not contained in a fixed number of cells in the column.
I need to copy the range from NC/xx/xxxx/x to Start Date plus one for each data "set", transpose it and paste all the data in the column in a new sheet.
Really haven't found anything useful so far but I am fumbling with this one:
Sub Find()
Dim Search, End, Start, i As Integer, j As Integer, L
Search = Cells(1, 1)
End = Cells(2, 1)
For i = 1 To 10160
If Left(Cells(i, 1), 3) = Search Then
Start = i - 0
End If
Next i
For j = 1 To 10160
If Cells(j, 1) = End Then
L = j + 1
End If
Sheet4.Select
Range(Cells(Start, 1), Cells(L + 2, 1)).Select
Selection.Copy
Sheet4.Range("BB23").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End
Next j
End Sub
Would really appreciate any help I can get!
Thanks!
It looks like you haven't had much interest in your question, so I've taken a look at it. It's one of those fiddly jobs - not terribly technical but tricky to get the flow of logic right. The code below gives you what you've outlined in your question. You've said transpose it - so that's what the code does. Try it and let me know how you go.
Option Explicit
Sub Copy2Sheet2()
'Declare all your variables
Dim ws1 As Worksheet, ws2 As Worksheet
Dim topRow As Long, BottomRow As Long, LastRow As Long
Dim PasteToRow As Long, i As Long, c As Range
'Set the sheet variables
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
'Initial row settings
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 '<~~ assumes headers on sheet2
'Start the loop
For i = 1 To LastRow
'Find the bottom row of the first block of data
Set c = ws1.Range("A" & i & ":A" & LastRow).Find(What:="Start Date", LookIn:=xlValues)
BottomRow = c.Row + 1
'Define and copy the range to sheet2
ws1.Range("A" & i & ":A" & BottomRow).Copy
ws2.Range("A" & PasteToRow).PasteSpecial Transpose:=True
Application.CutCopyMode = False
'Redefine the 'paste to' row
PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Redefine the top row of the next block of data
i = BottomRow
'Repeat the process
Next i
End Sub
I have hit a brick wall with this. This code works in stages, probably not very efficiently.
Step 1 looks at the data on sheet1 if row13 contains a yes then it copies that columns row17,20,21 to sheet2 this part I have got to work fine through a loop.
Step 2 selects the data on sheet2 looking at the last column and row and then should transpose it to sheet3. This part doesn't work at all. If i could skip the sheet3 and transpose direct onto sheet2 with the loop that would be even better.
Here is a screen shot of sheet1 the blanks do have data in the final sheet but are not applicable for this so have been removed.
Here is a screen shot of sheet2 this is currently how it appears after the loop.
This is how i imagine it looks when it is transposed sheet3
Here is my code so far: -
Sub Collect()
ThisWorkbook.Worksheets("Sheet2").Range("B1:U9999").ClearContents
Dim i As Integer
For i = 2 To 21
If Cells(13, i) = "Yes" Then
ThisWorkbook.Worksheets("Sheet1").Select
ThisWorkbook.Worksheets("Sheet1").Cells(17, i).Copy 'Name
ThisWorkbook.Worksheets("Sheet2").Select
ThisWorkbook.Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 'Paste Name
ThisWorkbook.Worksheets("Sheet1").Select
ThisWorkbook.Worksheets("Sheet1").Cells(20, i).Copy 'Lines
ThisWorkbook.Worksheets("Sheet2").Select
ThisWorkbook.Worksheets("Sheet2").Cells(2, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 'Paste Name
ThisWorkbook.Worksheets("Sheet1").Select
ThisWorkbook.Worksheets("Sheet1").Cells(21, i).Copy 'Quantity
ThisWorkbook.Worksheets("Sheet2").Select
ThisWorkbook.Worksheets("Sheet2").Cells(3, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 'Paste Quantity
ThisWorkbook.Worksheets("Sheet1").Select
End If
Next i
ThisWorkbook.Worksheets("Sheet3").Range("A1:U9999").ClearContents
ThisWorkbook.Worksheets("Sheet2").Select
Dim lRow As Long, lCol As Long
lRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
lCol = Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("Sheet2").Range(Cells(lRow, 1), Cells(lRow, lCol)).Select 'it errors here
Selection.Copy
ThisWorkbook.Worksheets("Sheet3").Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
I have highlighted where it has an error.
I have tried recording a macro to get the transpose part, which gave this result: -
Sub Transpose()
'
' Transpose Macro
Range("A1:F3").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub
So i would like help getting the selection on sheet2 which can vary to copy and transpose. If anyone has any suggestions on how to make it slicker would also be appreciate.
If you can explain what you do, this will help me learn, thank you!
Any help would be greatly appreciated.
Read this on how to avoid Select, which makes your code more efficient and tidier.
The immediate cause of your error was not fully qualifying ranges by adding worksheet references.
This should work.
Sub x()
Dim c As Long
With Worksheets("Sheet1")
For c = 1 To .Cells(13, Columns.Count).End(xlToLeft).Column
If .Cells(13, c).Value = "Yes" Then
Union(.Cells(17, c), .Cells(20, c), .Cells(21, c)).Copy
Sheet2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True
End If
Next c
End With
End Sub
Try,
Sub test()
Dim vDB, vResult()
Dim Ws As Worksheet, toWs As Worksheet
Dim j As Integer, n As Integer, c As Integer
Set Ws = Sheets(1)
Set toWs = Sheets(2)
With Ws
c = .Cells(13, Columns.Count).End(xlToLeft).Column
vDB = .Range("b13", .Cells(21, c))
End With
For j = 1 To UBound(vDB, 2)
If vDB(1, j) = "Yes" Then
n = n + 1
ReDim Preserve vResult(1 To 3, 1 To n)
vResult(1, n) = vDB(5, j)
vResult(2, n) = vDB(8, j)
vResult(3, n) = vDB(9, j)
End If
Next j
With toWs
.Range("a1").CurrentRegion.Clear
.Range("a1").Resize(1, 3) = Array("Name", "Lines", "Quantity")
If n Then
.Range("a2").Resize(n, 3) = WorksheetFunction.Transpose(vResult)
End If
End With
End Sub
This isn't complex by far but I'm only a novice at excel macros. I've found online and edited this for my use but I know it's so long. The single ranges all refer to the same cell which is just the value of =today(). I know that can be integrated, I just don't know how. The rest copies a row and pastes it over at the bottom of specific rows, one for each employee. I'm sure there are even better ways to do this since the rows being copied are only there for this code and isn't the main data source. But one step at a time. Lol
Sub LastRowDtDataTEST()
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long
Set wb = ActiveWorkbook
Set ws = ThisWorkbook.Sheets("Buyer Trend Metrics")
ws.Select
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "J").End(xlUp).Row
Range("J" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B61:H61").Copy
LastRow = Cells(Rows.Count, "K").End(xlUp).Row ' get last row with data in column "K"
Range("K" & LastRow + 1).PasteSpecial Paste:=xlPasteValues ' paste values
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "S").End(xlUp).Row
Range("S" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B62:H62").Copy
LastRow = Cells(Rows.Count, "T").End(xlUp).Row
Range("T" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "AB").End(xlUp).Row
Range("AB" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B63:H63").Copy
LastRow = Cells(Rows.Count, "AC").End(xlUp).Row
Range("AC" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "AK").End(xlUp).Row
Range("AK" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B64:H64").Copy
LastRow = Cells(Rows.Count, "AL").End(xlUp).Row
Range("AL" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "AT").End(xlUp).Row
Range("AT" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B65:H65").Copy
LastRow = Cells(Rows.Count, "AU").End(xlUp).Row
Range("AU" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "BC").End(xlUp).Row
Range("BC" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B66:H66").Copy
LastRow = Cells(Rows.Count, "BD").End(xlUp).Row
Range("BD" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "BL").End(xlUp).Row
Range("BL" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B67:H67").Copy
LastRow = Cells(Rows.Count, "BM").End(xlUp).Row
Range("BM" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "BU").End(xlUp).Row
Range("BU" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B68:H68").Copy
LastRow = Cells(Rows.Count, "BV").End(xlUp).Row
Range("BV" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "CD").End(xlUp).Row
Range("CD" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B69:H69").Copy
LastRow = Cells(Rows.Count, "CE").End(xlUp).Row
Range("CE" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B58").Copy ' Copies the value of =Today() from a cell. Would be easier to just integrate today's date instead.
LastRow = Cells(Rows.Count, "CM").End(xlUp).Row
Range("CM" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
Range("B70:H70").Copy
LastRow = Cells(Rows.Count, "CN").End(xlUp).Row
Range("CN" & LastRow + 1).PasteSpecial Paste:=xlPasteValues
End Sub
Here are some things for you to look at...
ALWAYS use Option Explicit. See here for an explanation.
When you're performing an action such as copying data, it's extremely helpful to be very clear in defining the source and destination of the data. This includes defining which Workbook the data is going to. You'll thank me later for building this habit now.
As an example:
Dim srcWB As Workbook
Dim dstWB As Workbook
Set srcWB = ThisWorkbook
Set dstWB = ThisWorkbook
Dim srcWS As Worksheet
Dim dstWS As Worksheet
Set srcWS = srcWB.Sheets("Sheet1") ' <--- you didn't specify this in your code
Set dstWS = dstWB.Sheets("Buyer Trend Metrics")
When you're performing the same (or very similar) actions over and over, it's the perfect situation to create a separate function that will perform the action for you. When you break out this section of code, it's called "functional isolation". This means that if you have a problem to fix, you only have to fix it in one place instead of finding all the different spots in your code that do the same thing.
In your case, you are performing a copy from one range of cells to another range of cells. So breaking that out into a separate routine looks like this:
Private Sub CopyMyData(ByRef fromData As Range, ByRef toData As Range)
Dim lastrow As Long
With toData.Parent
lastrow = .Cells(.Rows.Count, toData.Column).End(xlUp).Row
End With
fromData.Copy
toData.Cells(lastrow).PasteSpecial Paste:=xlPasteValues
End Sub
Notice here how I'm using variable names that describe what the code does (fromData and toData). This makes it clear what's happening.
Put it all together and your code will look something like this:
Option Explicit
Public Sub StartCopying()
Dim srcWB As Workbook
Dim dstWB As Workbook
Set srcWB = ThisWorkbook
Set dstWB = ThisWorkbook
Dim srcWS As Worksheet
Dim dstWS As Worksheet
Set srcWS = srcWB.Sheets("Sheet1") ' <--- you didn't specify this in your code
Set dstWS = dstWB.Sheets("Buyer Trend Metrics")
CopyMyData fromData:=srcWS.Range("B58"), toData:=dstWS.Range("J:J")
CopyMyData fromData:=srcWS.Range("B61:H61"), toData:=dstWS.Range("K:K")
CopyMyData fromData:=srcWS.Range("B58"), toData:=dstWS.Range("S:S")
CopyMyData fromData:=srcWS.Range("B61:H62"), toData:=dstWS.Range("T:T")
End Sub
Private Sub CopyMyData(ByRef fromData As Range, ByRef toData As Range)
Dim lastrow As Long
With toData.Parent
lastrow = .Cells(.Rows.Count, toData.Column).End(xlUp).Row
End With
fromData.Copy
toData.Cells(lastrow).PasteSpecial Paste:=xlPasteValues
End Sub
There's a pattern to how you're copying/pasting.
Copying every row, pasting to every 9th column after column 10.
I've added two lines for finding the last row - either find it once and paste everything to that row, of find it before you copy each time. Uncomment whichever you prefer.
This will copy B61:H61 to K:P on the last row (with date in J), then B62:H62 to T:Z with the date in R.
The date will also appear correctly formatted rather than as a number.
Public Sub WhateverYouWantToCallIt()
Dim x As Long, y As Long
Dim lLastRow As Long
With ThisWorkbook.Worksheets("Buyer Trend Metrics")
'This will set the same last row for each copy.
lLastRow = .Cells(.Rows.Count, 10).End(xlUp).Row + 1
y = 10
For x = 61 To 70
'This will set the last row on each set of data.
'lLastRow = .Cells(.Rows.Count, y).End(xlUp).Row + 1
.Cells(lLastRow, y) = Date
.Range(.Cells(lLastRow, y + 1), .Cells(lLastRow, y + 7)) = _
.Range(.Cells(x, 2), .Cells(x, 8)).Value
'-OR-
'.Range(.Cells(x, 2), .Cells(x, 8)).Copy
'.Cells(lLastRow, y + 1).PasteSpecial Paste:=xlPasteValues
y = y + 9
Next x
End With
End Sub
Do not double space every single line. You should use these as strategic separators, not the standard. This isn't MLA.
Use a worksheet variable to quickly refer to your sheets (ws refers to the sheet that has the cells to be copied and ds (destination sheet) refers to the sheet where the cells are to be pasted
You can use a value transfer instead of a copy/paste which does not require multiple lines as well
In general, when shortening code, you want to look for repetitiveness. I can see that you are constantly copying the value from Range("B58") so you can also shorten this. You have comments saying you want the value to just be today so you can just do something like
ds.Range("?") = Today Repeat as needed
Option Explicit
Sub LastRowDtData()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ds As Worksheet: Set ds = ThisWorkbook.Sheets("Buyer Trend Metrics")
Dim LR As Long
LR = ds.Range("J" & ds.Rows.Count).End(xlUp).Offset(1)
ds.Range("J" & LR).Value = ws.Range("B58").Value
LR = ds.Range("K" & ds.Rows.Count).End(xlUp).Offset(1)
ds.Range("K" & LR).Resize(1, 7).Value = ws.Range("B61:H61")
LR = ds.Range("S" & ds.Rows.Count).End(xlUp).Offset(1)
ds.Range("S" & LR).Value = ws.Range("B58").Value
'Repeat for below ranges
'------------------
Range("B62:H62").Copy
Range("B58").Copy
Range("B63:H63").Copy
Range("B58").Copy
Range("B64:H64").Copy
Range("B58").Copy
Range("B65:H65").Copy
Range("B58").Copy
Range("B66:H66").Copy
Range("B58").Copy
Range("B67:H67").Copy
Range("B58").Copy
Range("B68:H68").Copy
Range("B58").Copy
Range("B69:H69").Copy
Range("B58").Copy
Range("B70:H70").Copy
End Sub
My script looks up the highest values in dailySht and pastes the values into a separate sheet recordSht, which usually works fine, but I sometimes get the error Object variable or With block variable not set. Below is the part of the code that returns the error.
Sub DailyBH()
Dim dailySht As Worksheet 'worksheet storing latest store activity
Dim recordSht As Worksheet 'worksheet to store the highest period of each day
Dim lColDaily As Integer ' Last column of data in the store activity sheet
Dim lCol As Integer ' Last column of data in the record sheet
Dim maxCustomerRng2 As Range ' Cell containing the highest number of customers
Dim maxCustomerCnt As Double ' value of highest customer count
Set dailySht = ThisWorkbook.Sheets("hourly KPI")
Set recordSht = ThisWorkbook.Sheets("#BH KPI")
With recordSht
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
With dailySht
lColDaily = .Cells(1, .Columns.Count).End(xlToLeft).Column
maxCustomerCnt = Round(Application.Max(.Range(.Cells(58, 1), .Cells(58, lColDaily))), 2)
Set maxCustomerRng2 = .Range(.Cells(58, 1), .Cells(58, lColDaily)).Find(What:=maxCustomerCnt, LookIn:=xlValues)
.Cells(4, maxCustomerRng2.Column).Copy
recordSht.Cells(4, lCol + 1).PasteSpecial xlPasteValues
recordSht.Cells(4, lCol + 1).PasteSpecial xlPasteFormats
.Cells(22, maxCustomerRng2.Column).Copy
recordSht.Cells(22, lCol + 1).PasteSpecial xlPasteValues
recordSht.Cells(22, lCol + 1).PasteSpecial xlPasteFormats
.Cells(40, maxCustomerRng2.Column).Copy
recordSht.Cells(40, lCol + 1).PasteSpecial xlPasteValues
recordSht.Cells(40, lCol + 1).PasteSpecial xlPasteFormats
.Cells(49, maxCustomerRng2.Column).Copy
recordSht.Cells(49, lCol + 1).PasteSpecial xlPasteValues
recordSht.Cells(49, lCol + 1).PasteSpecial xlPasteFormats
.Cells(58, maxCustomerRng2.Column).Copy
recordSht.Cells(58, lCol + 1).PasteSpecial xlPasteValues
recordSht.Cells(58, lCol + 1).PasteSpecial xlPasteFormats
End With
Set maxCustomerRng = Nothing
Set dailySht = Nothing
Set recordSht = Nothing
End Sub
Can someone please help me figure out that the problem is, as the code works (copies and pastes the correct values) on some cells and not others.
I recommend to use Match instead of Find and use the result of Max directly without converting it into Double to avoid floating point inaccuracies.
With dailySht
lColDaily = .Cells(1, .Columns.Count).End(xlToLeft).Column
Dim SearchRange As Range
Set SearchRange = .Range(.Cells(58, 1), .Cells(58, lColDaily))
Dim MaxCol As Long
On Error Resume Next 'next line throws error if nothing matched
MaxCol = Application.WorksheetFunction.Match(Application.WorksheetFunction.Max(SearchRange), SearchRange, 0)
On Error GoTo 0 're-enable error reporting !!!
If MaxCol = 0 Then
'nothing was found
Exit Sub
End If
.Cells(4, MaxCol).Copy
'your stuff here
Im having an issue writing VBA to Autosum where columns may increase or decrease from time to time. Take below as an example. I have set my LastCol to find the last column, i then want to autosum from column B on the row to the last column to get my 'Total. I want to avoid R1C1 Formulas where possible. Also the RC[-4] will change depending how many columns are on spreadsheet.
Sub AutoSum()
Dim LastCol As Integer
Sheets("Sheet1").Select
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Cells(2, LastCol1 + 1).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,RC[-4]: RC[-1])"
End Sub
Give this a shot:
Sub AutoSum()
Dim LastCol As Integer
With Sheets("Sheet1")
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(2, LastCol1 + 1).Formula = "=SUBTOTAL(9,Offset(B2,0,0,1," & LastCol-1 & "))"
End With
End Sub
After running above code: