[
I am working on two sheets
Sheets("UPDATER") = where input data is placed (more than 700 rows) and where data needs to be copied
Sheets("Historical_vol) = where i have kept the formulas (C9:N9) and input the records from updater sheet in cell A9 of historical_vol sheet.
The aim is to get the values of each of Underlyings pasted in sheets("updater").columns("AB") but the values get calculated from sheets("Historical_vol").column(C9:F9) then paste these values in sheet("updater")on each row starts from cell AD4.
Sub historical_vol()
Dim i As Long
Dim a As Worksheet
Dim b As Worksheet
lr = Worksheets("UPDATER").Cells(Rows.count, "AB").End(xlUp).Row
Set a = Worksheets("UPDATER")
Set b = Worksheets("Historical_vol")
For i = 4 To lr
b.Range("A9").value = a.Range("AB4" & i).value
'b.Range("C9":F9").Calculate
Application.Wait (Now + TimeValue("00:00:02"))
b.Range("C9:F9").Copy
NextRow = Cells(Rows.count, "AD").End(xlUp).Row + 1
Cells(NextRow, "AD").Select
ActiveSheet.Paste
Next i
End Sub
At first I notice the line b.Range("A9").value = a.Range("AB4" & i).value should be b.Range("A9").value = a.Range("AB" & i).value
As I see you are using Application.Wait, I assume it is for the calculation. So, I suggest using xlCalculationManual calculation and resetting it to auto once done as below.
Sub historical_vol()
Application.ScreenUpdating = True
'This will help to watch the status bar update
Application.Calculation = xlCalculationManual
Dim wb As Workbook, uPd As Worksheet, hV As Worksheet
Dim lr As Long, cl As Range
Set wb = ThisWorkbook
Set uPd = wb.Sheets("UPDATER")
Set hV = wb.Sheets("Historical_vol")
lr = uPd.Cells(Rows.Count, "AB").End(xlUp).Row
i = 0
For Each cl In uPd.Range("AB4:AB" & lr)
hV.Range("A9").Value = cl.Value
hV.Calculate
cl.Offset(0, 2).Resize(1, 4).Value = hV.Range("C9:F9").Value
i = i + 1
Application.StatusBar = i '& " / " & lr - 3
'View on status bar number of records completed out of total records (lr-3)
Next
Application.Calculation = xlCalculationAutomatic
End Sub
Related
I have trouble running this script to obtain Summary information for a specific month. I am explaining below the details of my workbook.
Tab 1 called "Schedule"
Tab 2 called "Results"
Tab 3 called "Sheet3"
I would like to obtain info from column C (Summary) in tab1 for the month of July. I am entering the month in tab2 and would like to run the macro and obtain all the results pertaining to the month of July.
Sub schedule()
Dim sch As Workbook
Dim schTot As Worksheet
Dim schRes As Worksheet
Dim i As Long
Dim j As Long
Let sch = Thisworkbook
Let schRes = sch.Worksheets("Results")
Let schTot = sch.Worksheets("Schedule")
For i = 1 To schTot.Range("A1").End(xlDown)
For j = 3 To schRes.Range("B3").End(xlDown)
If schTot.Cells(i, 1).Value = schRes.Cells(1, 2).Value Then
If schRes.Cells(j, 1).Value = "" Then
schTot.Rows(i).Copy
schRes.Cells(j, 1).Paste
Application.CutCopyMode = False
'Exit For
End If
End If
Next j
Next i
End Sub
Try this:
Option Explicit
Sub schedule()
Dim sch As Workbook
Dim schTot As Worksheet
Dim schRes As Worksheet
Dim i As Long
Dim j As Long
Dim strMonth As String
With ThisWorkbook
Set schRes = .Worksheets("Results")
Set schTot = .Worksheets("Schedule")
End With
schRes.Range("A3:C" & schRes.Cells(3, 1).End(xlDown).Row).ClearContents
strMonth = schRes.Cells(1, 2).Value
i = 2
j = 3
With schTot
Do Until .Cells(i, 1).Value = ""
If .Cells(i, 1).Value = strMonth Then
schRes.Range("A" & j & ":C" & j).Value = .Range("A" & i & ":C" & i).Value
j = j + 1
End If
i = i + 1
Loop
End With
End Sub
For your code, you just need to change following things to get it run:
-use "Set" instead of "Let"
Set sch = Thisworkbook
Set schRes = sch.Worksheets("Results")
Set schTot = sch.Worksheets("Schedule")
-return row's number in for loop condition
For i = 1 To schTot.Range("A1").End(xlDown).Row
For j = 3 To schRes.Range("B3").End(xlDown).Row
Then your code will be ok to run, but if your B3 cell in Results worksheet don't have value or following cells(i.e. B4,B5,B6...) doesn't have vale, your code will run infinitely and crush eventually.
Also, you copy a entire row in loop every single time which contain unnecessary cells. This will horribly slow down your code.
To speed up the code, I recommend to use auto filter to solve the problem:
Sub sechedule()
Dim sch As Workbook: Set sch = ThisWorkbook
Dim schTot As Worksheet: Set scTot = sch.Worksheets("Schedule")
Dim schRes As Worksheet: Set schRes = sch.Worksheets("Results")
Dim month As String
month = Range("B1").Value 'The month you inputted in Results worksheet
'I suppose you want to paste the result to Results worksheet starting from Cell A3, so the contents will be cleared first each time if somethings are in the result area:
If Range("A3").Value = "" Then Range("A3:C" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
With schTot
.Activate
.Range("A:C").AutoFilter Field:=1, Criterial:=month 'Choose data for specific month with auto filter
.Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=schRes.Range("A3") '<--You can change the paste destination here
.ShowAllData
.Range("A:C").AutoFilter 'Cancel auto filter
End With
schRes.Activate
End Sub
I'm trying to fix the code to copy all rows based on unique values in a column to new worksheets
1. The table has a header in the range A1:CM4 that also includes a small picture
2. The last row contains a SUM formulas for each column C:CM
Trying to get:
1. Create new worksheets for each unique values in a column A (copy all appropriate rows, some cells are empty) including the header (A1:CM4) with the picture
3. Name new worksheets based on unique values (can be long names with spaces and commas: "aaaaa and bbbb, cccc")
4. The last row should contain SUM formulas and formatting for each column C:CM
I have a code that does part of the job (creates new sheets with unique values), but still struggling to fix next issues:
1. Doesn't copy all header (now copies only 1st row out of 4)
2. Doesn't keep/copy the last row with SUM formulas
3. Doesn't name a worksheet if the unique value is like: "aaaaa and bbbb, cccc" (less important)
Sub unique_data()
Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim TRrow As Integer
Dim Col As New Collection
Dim Title As String
Dim SUpdate As Boolean
Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Title = "A1"
TRrow = Sht.Range(Title).Cells(1).Row
For I = 5 To RCount
Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next
SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To Col.Count
Call Sht.Range(Title).AutoFilter(1, CStr(Col.Item(I)))
Set NSht = Nothing
Set NSht = Worksheets(CStr(Col.Item(I)))
If NSht Is Nothing Then
Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
NSht.Name = CStr(Col.Item(I))
Else
NSht.Move , Sheets(Sheets.Count)
End If
Sht.Range("A" & TRrow & ":A" & RCount).EntireRow.Copy NSht.Range("A1")
NSht.Columns.AutoFit
Next
Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
End Sub
Would be very grateful for any help!
I managed to fix my code and get the correct results (still have some issues with naming spreadsheets as some names are rather long and excel does not take them to name the tabs), but anyways here is what the code is doing:
1. Creates new spreadsheets and copies appropriate rows based on unique values in a certain range (A5:..) of the main sheet
2. Renames new spreadsheets based on unique values
3. Copies all header's rows (4) to new spreadsheets
4. Copies the last row with SUM formulas and adjust the sum range for each spreadsheets based on the number of returned records
5. Formats new spreadsheets
I hope someone can use this code to solve similar puzzles or maybe make it more efficient.
Sub unique_data()
Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim Col As New Collection
Dim SUpdate As Boolean
Dim Lrow As Long
Dim NShtLR As Long
Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Lrow = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
For I = 5 To RCount
Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next
SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To Col.Count
Call Sht.Range("A5").AutoFilter(1, CStr(Col.Item(I)))
Set NSht = Nothing
Set NSht = Worksheets(CStr(Col.Item(I)))
If NSht Is Nothing Then
Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
NSht.Name = CStr(Col.Item(I))
Else
NSht.Move , Sheets(Sheets.Count)
End If
Sht.Range("A5:A" & RCount).EntireRow.Copy NSht.Range("A5")
Next
Sheets.FillAcrossSheets Sht.Range("1:4")
For Each NSht In Worksheets
If Not NSht.Name = "MainReport" Then
NSht.Select
NShtLR = NSht.Cells(Sht.Rows.Count, 1).End(xlUp).Row + 1
Sht.Range("A" & Lrow).EntireRow.Copy NSht.Range("A" & NShtLR)
NSht.Range("C" & NShtLR).Formula = "=SUM(C5:C" & NShtLR - 1 & ")"
Range("C" & NShtLR).Copy Range("C" & NShtLR & ":CM" & NShtLR)
Rows("4:4").RowHeight = 230
Columns("A:A").ColumnWidth = 28
Columns("B:B").ColumnWidth = 29
Columns("C:C").ColumnWidth = 3
Columns("D:CB").ColumnWidth = 3.5
Columns("CC:CM").ColumnWidth = 4
NSht.Shapes.Range(Array("Picture 1")).Select
Selection.ShapeRange.IncrementLeft -3.6
Selection.ShapeRange.IncrementTop 47.4
Rows.EntireRow.Hidden = False
ActiveWindow.Zoom = 70
End If
Next
Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
End Sub
I've written some code that assigns each item in a list a code based on row #. What I want to do from there is choose a copy all information from each row that corresponds with a chosen code, then paste it to another workbook. I've been having some trouble. Here's the code:
Sub LSHP_Distribute()
Dim wbLSHP As Workbook
Dim wsLSHP As Worksheet
Dim CodeRange As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim wbTEST As Workbook
Set wbLSHP = ActiveWorkbook
Set wsLSHP = wbLSHP.Sheets("Sheet1")
'Generate codes for newly added items
Application.ScreenUpdating = False
'Turn off screen updating
With wsLSHP
FirstRow = .Range("F3").End(xlDown).Row + 1
LastRow = .Range("B6", .Range("B6").End(xlDown)).Rows.Count + 5
Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow)
End With
For Each cell In CodeRange
If cell = "" Then
If cell.Row Mod 3 = 0 Then
cell.Value = "1"
ElseIf cell.Row Mod 3 = 1 Then
cell.Value = "2"
ElseIf cell.Row Mod 3 = 2 Then
cell.Value = "3"
Else
End If
End If
Next cell
'Open Spreadsheets to Distribute Items
Dim PasteRow As Long
Dim i As Integer
Set wbTEST = Workbooks.Open(Filename:="V:\Test.xlsx")
PasteRow = wbTEST.Sheets("Sheet1").Range("B6").End(xlDown).Row + 1
Below is where I'm having the problem
wbLSHP.Activate
For Each cell In CodeRange
If cell = "1" Then
Range(ActiveCell.Offset(0, -5), ActiveCell.Offset(0, 20)).Select
Selection.Copy
wbTEST.Sheets("Sheet1").Cells(PasteRow, 1).PasteSpecial xlPasteValues
PasteRow = PasteRow + 1
Else
End If
Next cell
End Sub
First problem is the For loop isn't copying the correct range in "CodeRange", the second problem is it only copies once before I get an Automation Error. Let me know if you have any questions, or know of a more efficient way to write this code.
Thanks so much for your time!
Your range is defined to Start in F3 and end in BSomething, but you store to CodeRange only the F column.
Set CodeRange = .Range("$F$" & FirstRow, "$F$" & LastRow)
Try using:
Set CodeRange = .Range("$B$" & FirstRow, "$F$" & LastRow)
I suggest instead of Copy and Paste, assign the value to a variable and put the value of the variable on wbTEST.
Intended Result
If a row in a table contains any of the listed strings in column L on Sheet1, Then copy the entire row from Sheet1 and paste the row into a duplicate table on Sheet2 (which would be blank at the beginning).
(UNINTERESTED, UNRELATED, UNDECIDED, etc...)
Then delete the entire row that was transferred from sheet 1.
After macro runs, the new transfers should not reset table on Sheet2, rather add rows on the pre-existing lines. This document would be utilized over months.
Variables
Sheet1 is named Pipeline_Input
Sheet2 is named Closed_Sheet
Sheet1 table is named tblData
Sheet2 table is named tblClosed
Images
Image 1 is the code with error
Image 2 is Sheet 1 with some picture explanation
Image 3 is Sheet 2 with some picture explanation
Current Result
Run-time error '1004':
Application-defined or object-defined error
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_input As Worksheet 'where is the data copied from
Dim Closed_Sheet As Worksheet 'where is the data pasted to
Dim strPhase() As String
Dim i As Integer
Dim intPhaseMax As Integer
Dim lngLstRow As Long
Dim rngCell As Range
Dim finalrow As Integer
Dim lr As Long 'row counter
Dim Looper As Integer
intPhaseMax = 6
ReDim strPhase(1 To intPhaseMax)
strPhase(1) = "LOST"
strPhase(2) = "BAD"
strPhase(3) = "UNINTERESTED"
strPhase(4) = "UNRELATED"
strPhase(5) = "UNDECIDED"
strPhase(6) = "BUDGET"
'set variables
Set Pipeline_input = Sheet1
Set Closed_Sheet = Sheet2
lr = Range("A" & Rows.Count).End(xlUp).Row
For Looper = LBound(strPhase) To UBound(strPhase)
For i = lr To 6 Step -1
Next
If Not Sheet1.Range("L9:L300" & lngLstRow).Find(strPhase(Looper), lookat:=xlWhole) Is Nothing Then
Range(Cells(i, 1), Cells(i, 20)).Copy
Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 20)).Delete
End If
Next
Sheet2.Select
Sheet2.columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Okay, there were a plethora of issues with the code you posted, but I decided to help you out here - Notice a few things - There's no copying and pasting here - we're just transferring data.
Secondly, use easy to understand variables. lr and lngLastRow can't be distinguished from one another, so classify them by which worksheet you're getting that value from.
We create an array in one fell swoop here - Just declare a variant and place our values in. ARRAYS (TYPICALLY) START AT ZERO, NOT ONE, so our loop starts at 0 :). Again, this is what's known as best practice...
I swapped out Looper for j. Again, keep. it. simple!
EDIT: I tested this code out on a simulated workbook and it worked fine - should run into no issues for you either.
EDIT2: Also, always use Option Explicit!
Option Explicit
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_Input As Worksheet 'source sheet
Dim Closed_Sheet As Worksheet 'destination sheet
Dim i As Long, j As Long, CSlastrow As Long, PIlastrow As Long
Dim strPhase As Variant
'Here we create our array
strPhase = Array("LOST", "BAD", "UNINTERESTED", "UNRELATED", "UNDECIDED", "BUDGET")
'Assign worksheets
Set Pipeline_Input = ActiveWorkbook.Worksheets("Pipeline_Input")
Set Closed_Sheet = ActiveWorkbook.Worksheets("Closed_Sheet")
PIlastrow = Pipeline_Input.Range("A" & Rows.Count).End(xlUp).Row
For j = 0 To UBound(strPhase)
For i = PIlastrow To 6 Step -1
If Pipeline_Input.Range("L" & i).Value = strPhase(j) Then
'Refresh lastrow value
CSlastrow = Closed_Sheet.Range("A" & Rows.Count).End(xlUp).Row
'Transfer data
Closed_Sheet.Range("A" & CSlastrow + 1 & ":S" & CSlastrow + 1).Value = _
Pipeline_Input.Range("A" & i & ":S" & i).Value
'Delete the line
Pipeline_Input.Range("A" & i & ":S" & i).EntireRow.Delete
End If
Next i
Next j
Closed_Sheet.Select
Closed_Sheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
I have two macros:
Macro 1: copy-paste a large worksheet into the same workbook (basically myWorksheet.copy after:=lastWorksheet)
Macro 2: Iterate through data in new worksheet to unmerge any merged cells. Then set the value of all cells in each MergeArea to the value of the original merged cell.
Both macros run as they should.
The problem is the runtime. If I run Macro 1 and Macro 2 in the same 'session' (the way it has to be) Macro 2 has a runtime of roughly 250s.
If I run Macro 1, then restart Excel and run Macro 2, Macro 2 takes only 1/3 of the time (~70s).
I tried clearing the clipboard after running Macro 1 but it does nothing. Otherwise I'm out of ideas.
Macro 1:
Sub copySheet()
Dim ws As Worksheet
Application.DisplayAlerts = False
Set ws = ThisWorkbook.Worksheets("BigData")
ws.Copy After:=ThisWorkbook.Worksheets("BigData")
Application.DisplayAlerts = True
End Sub
Macro 2:
Sub unmergeCells()
Dim ws As Worksheet
Dim szArr() As Integer
Dim i%, k%, j%, col%
Dim strt&
'First row
Const fr% = 9
'First column
Const fc% = 12
'Last column
Const lc% = 135
'Last row
Const lr% = 1196
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws = ThisWorkbook.Worksheets("BigData (2)")
strt = VBA.Timer
With ws
For col = fc To lc
'Some columns only have to be unmerged without changing any values
If IsNumeric(.Cells(fr - 1, col)) Then
.Range(.Cells(fr, col), .Cells(lr, col)).UnMerge
GoTo Skip_Ahead
End If
i = fr
k = 0
Do While i <= lr
ReDim Preserve szArr(k)
szArr(k) = i
i = i + .Cells(i, col).MergeArea.Cells.Count
k = k + 1
Loop
.Range(.Cells(fr, col), .Cells(lr, col)).UnMerge
For i = 0 To UBound(szArr) - 1
For j = szArr(i) + 1 To szArr(i + 1) - 1
.Cells(j, col) = "'" & .Cells(szArr(i), col)
Next j
Next i
Skip_Ahead:
Debug.Print col & ": " & Timer - strt
Next col
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub