Basically, I am trying to pull the data from an Excel file to this worksheet (Auto_Update Sub) and the code is described below:
Sub Auto_Update()
Dim filename As String
Dim r As Integer
Dim i As Double
Dim t As Integer
Dim DPR As Object
Dim new_DPR As Object
Dim well As Object
Dim x As Integer
If IsEmpty(ThisWorkbook.Sheets("SD-28P").Cells(1, 35)) = True Then
ThisWorkbook.Sheets("SD-28P").Cells(1, 35) = Date - 2
End If
Excel.Application.Visible = False
For i = Date - ThisWorkbook.Sheets("SD-28P").Cells(1, 35) To 1 Step -1
filename = "Z:\DPR\DPR_" + Format(Date - i, "yyyymmdd") + ".xls"
Set DPR = Excel.Application.Workbooks.Open(filename)
Set new_DPR = DPR.Worksheets("Daily Production Report")
For x = 247 To 272 Step 1
If Trim(new_DPR.Cells(x, 2).Value) = "SD-01PST" Then t = x
Exit For
For r = t To t + 35 Step 1
Set well = ThisWorkbook.Worksheets(Trim(new_DPR.Cells(r, 2).Value))
f = First_Empty(well, 4)
If new_DPR.Cells(r, 6).Value = Date - i Then
new_DPR.Cells(r, 6).Copy
well.Cells(f, 1).PasteSpecial (xlPasteValues)
new_DPR.Cells(r, 8).Copy
well.Cells(f, 3).PasteSpecial (xlPasteValues)
new_DPR.Cells(r, 10).Copy
well.Cells(f, 4).PasteSpecial (xlPasteValues)
new_DPR.Range(new_DPR.Cells(r, 12), new_DPR.Cells(r, 17)).Copy
well.Range(well.Cells(f, 5), well.Cells(f, 10)).PasteSpecial (xlPasteValues)
new_DPR.Range(new_DPR.Cells(r, 20), new_DPR.Cells(r, 26)).Copy
well.Range(well.Cells(f, 11), well.Cells(f, 17)).PasteSpecial (xlPasteValues)
new_DPR.Range(new_DPR.Cells(r, 28), new_DPR.Cells(r, 30)).Copy
well.Range(well.Cells(f, 18), well.Cells(f, 20)).PasteSpecial (xlPasteValues)
well.Range(well.Cells(f - 1, 2), well.Cells(f - 1, 22)).Copy
well.Range(well.Cells(f, 2), well.Cells(f, 22)).PasteSpecial (xlPasteFormats)
well.Cells(f - 1, 1).Copy
well.Cells(f, 1).PasteSpecial (xlPasteFormulasAndNumberFormats)
End If
Next r
Excel.Application.CutCopyMode = False
DPR.Saved = True
DPR.Close
ThisWorkbook.Application.CutCopyMode = False
Next i
ThisWorkbook.Sheets("SD-28P").Cells(1, 35) = Date
ThisWorkbook.Save
Excel.Application.Visible = True
ThisWorkbook.Sheets(4).Activate
But then, the code returns an error at the line: Next i (Invalid Next Control Variable Reference). I double checked the variable and the syntacx of the For ... Next loop, however, I couldn't not find any possible error. Please kindly help! Thank you very much in advance.
You never close the loop that starts with
For x = 247 To 272 Step 1
If Trim(new_DPR.Cells(x, 2).Value) = "SD-01PST" Then t = x
Exit For
You need a next x somewhere before you can use a next i.
Related
I have some vba code that evaluates 6 columns and formats the dates from yyyymmdd to mm/dd/yyyy. The code works fine until it finds a blank cell within the range and then I get a type 13 Run time error. The debugger highlights the DateSerial line so I assume thats where my issue is.
Any thoughts?
Sub Convert_Date()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Range("AC2:AC" & Cells(Rows.Count, "AC").End(xlUp).Row)
c.Value = DateSerial(Left(c.Value, 4), Mid(c.Value, 5, 2), Right(c.Value, 2))
c.NumberFormat = "mm/dd/yyyy"
Next
Application.ScreenUpdating = False
Dim b As Range
Application.ScreenUpdating = False
For Each b In Range("AL2:AL" & Cells(Rows.Count, "AL").End(xlUp).Row)
b.Value = DateSerial(Left(b.Value, 4), Mid(b.Value, 5, 2), Right(b.Value, 2))
b.NumberFormat = "mm/dd/yyyy"
Next
Application.ScreenUpdating = False
Dim a As Range
Application.ScreenUpdating = False
For Each a In Range("AQ2:AQ" & Cells(Rows.Count, "A").End(xlUp).Row)
a.Value = DateSerial(Left(a.Value, 4), Mid(a.Value, 5, 2), Right(a.Value, 2))
a.NumberFormat = "mm/yyyy"
Next
Application.ScreenUpdating = False
Dim d As Range
Application.ScreenUpdating = False
For Each d In Range("AR2:AR" & Cells(Rows.Count, "A").End(xlUp).Row)
d.Value = DateSerial(Left(d.Value, 4), Mid(d.Value, 5, 2), Right(d.Value, 2))
d.NumberFormat = "mm/yyyy"
Next
Application.ScreenUpdating = False
Dim e As Range
Application.ScreenUpdating = False
For Each e In Range("AT2:AT" & Cells(Rows.Count, "A").End(xlUp).Row)
e.Value = DateSerial(Left(e.Value, 4), Mid(e.Value, 5, 2), Right(e.Value, 2))
e.NumberFormat = "mm/yyyy"
Next
Application.ScreenUpdating = False
Dim f As Range
Application.ScreenUpdating = False
For Each f In Range("AU2:AU" & Cells(Rows.Count, "A").End(xlUp).Row)
f.Value = DateSerial(Left(f.Value, 4), Mid(f.Value, 5, 2), Right(f.Value, 2))
f.NumberFormat = "mm/yyyy"
Next
Application.ScreenUpdating = False
End Sub
Try to make a check around each condition, whether the value is not empty. Like this:
If Not IsEmpty(c) then
c.Value = DateSerial(Left(c.Value, 4), Mid(c.Value, 5, 2), Right(c.Value, 2))
c.NumberFormat = "mm/dd/yyyy"
End If
Once you get deeper into VBA, you may start using functions like this:
Sub Convert_Date()
Application.ScreenUpdating = False
RockAndRoll "AC2:AC", "AC"
Call RockAndRoll ("AR2:AR", "A")
RockAndRoll "AL2:AL", "AC"
'RockAndRoll etc...
Application.ScreenUpdating = True
End Sub
Public Sub RockAndRoll(myLeft As String, myRight As String)
Dim a As Range
With ActiveSheet
For Each a In .Range(myLeft & .Cells(.Rows.Count, myRight).End(xlUp).Row)
If Not IsEmpty(a) Then
a.value = DateSerial(Left(a.value, 4), Mid(a.value, 5, 2), Right(a.value, 2))
a.NumberFormat = "mm/yyyy"
End If
Next
End With
End Sub
So you should not be repeating the code over and over again.
I have a very large data set (600,000 rows) of data structured in the following format:
1) There are around 60 products. One is a Total US number, while the others are for Manufacturers and are labled as KMFs. There are also some labeled as PCKGs(but aren't relevant for this question)
2) Each product is located in 60 different markets
3) Each market has 20 different locations
4) I have 12 metrics for which I need to calculate data in the following manner: Total US number - sum(KMFs) for each metric
I have written vba code for this but it is taking too long to run(around 20 minutes) I need to run similar code on at least 20 worksheets. I have tried various methods such as setting screenUpdating etc. to false. Here is my code. I am new to vba coding so I may have missed obvious things. Please let me know anything is unclear. Please help!
Sub beforeRunningCode()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End Sub
Sub returnToOriginal()
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState
End Sub
Function LastRowFunc(Sheet) As Long
LastRowFunc = ActiveWorkbook.Worksheets(Sheet).Range("A2", Worksheets(Sheet).Range("A2").End(xlDown)).Rows.Count
End Function
Function LastColFunc(Sheet) As Long
With ActiveSheet
LastColFunc = ActiveWorkbook.Sheets(Sheet).Cells(1, .Columns.Count).End(xlToLeft).Column
End With
End Function
Sub AOCalculate()
Call beforeRunningCode 'Optimize Excel
Dim LastRow As Long
Dim LastCol As Long
Dim Period As String
Dim Sheet As String
Dim Arr(1 To 16)
Dim Count As Integer
Sheet = "Energy_LS_Bottler"
Period = "2016 WAVE 1 - 3 W/E 05/07"
LastRow = LastRowFunc(Sheet) 'Calculate last row for which data exists
LastCol = LastColFunc(Sheet) 'Calculate last column for which data exists
For Each Location In ActiveWorkbook.Sheets("Locations").Range("D7:D28").Value
For Each Market In ActiveWorkbook.Sheets("Markets").Range("A5:A92").Value
Count = Count + 1
Arr(1) = Market
Arr(2) = "AO"
Arr(3) = Location
Arr(4) = Period
With ActiveWorkbook.Sheets(Sheet) 'Filtering for KMF
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=17, Criteria1:="=KMF"
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=1, Criteria1:=Market
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=3, Criteria1:=Location
End With
For k = 5 To 16
Arr(k) = Application.WorksheetFunction.Sum(ActiveWorkbook.Sheets(Sheet).Range(Cells(1, k), Cells(LastRow, k)).SpecialCells(xlCellTypeVisible))
Next k
With ActiveWorkbook.Sheets(Sheet) ' filtering for Total US
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=17, Criteria1:="=Total US"
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=1, Criteria1:=Market
.Range(Cells(1, 1), Cells(LastRow, LastCol)).AutoFilter field:=3, Criteria1:=Location
End With
For k = 5 To 16
Arr(k) = -Arr(k) + Application.WorksheetFunction.Sum(ActiveWorkbook.Sheets(Sheet).Range(Cells(1, k), Cells(LastRow, k)).SpecialCells(xlCellTypeVisible))
Next k
For j = 1 To 16
ActiveWorkbook.Sheets(Sheet).Cells(LastRow + Count, j).Value = Arr(j)
Next j
Erase Arr
Next
Next
ActiveWorkbook.Sheets(Sheet).AutoFilterMode = False
Call returnToOriginal
End Sub
[Edit]: Here is a link to a sample data set https://drive.google.com/file/d/0B3MkGa57h6g_WGl2WWlWekd4NU0/view?usp=sharing
I think that this will work (though I haven't had a chance to test it), and should be a lot faster:
Sub AOCalculate()
Call beforeRunningCode 'Optimize Excel
Dim LastRow As Long
Dim LastCol As Long
Dim Period As String
Dim Sheet As String
Dim Arr() '1 To 2000, 1 To 16)
Dim Count As Integer
Sheet = "Energy_LS_Bottler"
Period = "2016 WAVE 1 - 3 W/E 05/07"
LastRow = LastRowFunc(Sheet) 'Calculate last row for which data exists
LastCol = LastColFunc(Sheet) 'Calculate last column for which data exists
'copy all of the relevant cells to local arrays for speed
Dim Locations(), Markets(), data()
Markets = ActiveWorkbook.Sheets("Markets").Range("A5:A92").Value
Locations = ActiveWorkbook.Sheets("Locations").Range("D7:D28").Value
'(pretty sure the following line needs to localize the Cells() to .Cells())
data = ActiveWorkbook.Sheets(Sheet).Range(Cells(1, 1), Cells(LastRow, LastCol)).Value '**'
ReDim Arr(1 To UBound(Markets, 1) * UBound(Locations, 1), 16)
'make an index of pointers into our accumulation array
Dim counts As New Collection
Dim i As Long, l As Long, m As Long
For l = 1 To UBound(Locations, 1)
Location = Locations(l, 1) '**'
For m = 1 To UBound(Markets, 1)
Market = Markets(m, 1) '**'
i = i + 1
counts.Add i, CStr(Location) & "~" & CStr(Market)
'counts.Add NewAccumArray(Location, Market, Period), CStr(Location) & "~" & CStr(Market)
Arr(i, 1) = Market
Arr(i, 2) = "AO"
Arr(i, 3) = Location
Arr(i, 4) = Period
Next
Next
' go through each row and add it to the appropiate count in the array
Dim r As Long
Dim key As String, idx As Long
For r = 1 To UBound(data, 1)
key = CStr(data(r, 3)) & "~" & CStr(data(r, 1))
If data(r, 17) = "KMF" Then
idx = counts(key)
For k = 5 To 16
Arr(idx, k) = Arr(idx, k) - data(r, k)
Next k
Else
If data(r, 17) = "Total US" Then
idx = counts(key)
For k = 5 To 16
Arr(idx, k) = Arr(idx, k) + data(r, k)
Next k
End If
End If
Next r
' output the results
ActiveWorkbook.Sheets(Sheet).Range(Cells(LastRow + 1, 1), Cells(LastRow + Count, 16)).Value = Arr
ActiveWorkbook.Sheets(Sheet).AutoFilterMode = False
Call returnToOriginal
End Sub
Answering the query "What did I mean by this?"
'(pretty sure the following line needs to localize the Cells() to .Cells())
data = ActiveWorkbook.Sheets(Sheet).Range(Cells(1, 1), Cells(LastRow, LastCol)).Value '**'
The use of Cells(..) here is fundamentally unreliable and broken. this is because Cells(..) is really a shortcut for ActiveSheet.Cells(..) and the Active* properties are inherently slow and unreliable because they can change while the code is running. Worse, this code is assuming that ActiveSheet = Energy_LS_Blotter which is far from certain.
The correct way to write this line would be like this:
data = ActiveWorkbook.Sheets(Sheet).Range( _
ActiveWorkbook.Sheets(Sheet).Cells(1, 1), _
ActiveWorkbook.Sheets(Sheet).Cells(LastRow, LastCol) _
).Value
But that is long, ugly and inconvenient. An easier way would be to use either a Sheet variable, or a With:
With ActiveWorkbook.Sheets(Sheet)
data = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).Value
End With
I have design the following code. I would like to understand if a named range can be used in the ws.cells(Y,2)? I have tried to name the code ws.Range("Name") but it failed. The intent is to search a column of data seeking out specific criteria (bold and <1). Once found, it populates the data results to another sheet. The search should be from top to bottom, until it finds the first 7 matches to the criteria. I am seeking assistance with writing the code so that is it 1) cleaner and 2) faster.
X = 12
Y = 4
Z = 0
Set ws = Worksheets("Schedule")
Do Until Z = 7
If ws.Cells(Y, 2).font.Bold = True And ws.Cells(Y, 2) < 1 Then
ws.Activate
ws.Cells(Y, 2).Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.Copy Destination:=Worksheets("Project Status").Cells(X, 3)
ws.Cells(Y, 2).Offset(rowOffset:=0, columnOffset:=3).Activate
ActiveCell.Copy Destination:=Worksheets("Project Status").Cells(X, 6)
ws.Cells(Y, 2).Offset(rowOffset:=0, columnOffset:=4).Activate
ActiveCell.Copy Destination:=Worksheets("Project Status").Cells(X, 7)
ws.Cells(Y, 2).Offset(rowOffset:=0, columnOffset:=0).Activate
ActiveCell.Copy Destination:=Worksheets("Project Status").Cells(X, 8)
X = X + 1
Y = Y + 1
Z = Z + 1
Else
Y = Y + 1
End If
Loop
Name range is a workbook level range, not a worksheet level range.
If the name range refers to the active sheet, then ws.range("name") will work. But if it refers to a non-active sheet, ws.range("name") will throw an error.
Because name range is a workbook level range, so you can simply do Range("name"). Then you'll not get the error above.
P/S: another way to write Range("Name") is [Name] which looks cleaner but missing the intellisense.
The following code does not address "sub question" in respect to *named ranges" as I did not understand that part.
Yet, the following code is a bit shorter and maybe even easier to read. Also, some minor improvements were made in respect to speed:
Option Explicit
Public Sub tmpSO()
Dim WS As Worksheet
Dim X As Long, Y As Long, Z As Long
X = 12
Z = 0
Set WS = ThisWorkbook.Worksheets("Schedule")
With Worksheets("Project Status")
For Y = 4 To WS.Cells(WS.Rows.Count, 2).End(xlUp).Row
If WS.Cells(Y, 2).Font.Bold And WS.Cells(Y, 2).Value2 < 1 Then
WS.Cells(Y, 2).Offset(0, 1).Copy Destination:=.Cells(X, 3)
WS.Cells(Y, 2).Offset(0, 3).Copy Destination:=.Cells(X, 6)
WS.Cells(Y, 2).Offset(0, 4).Copy Destination:=.Cells(X, 7)
WS.Cells(Y, 2).Offset(0, 0).Copy Destination:=.Cells(X, 8)
X = X + 1
Z = Z + 1
' Else
' Y = Y + 1
End If
If Z = 7 Then Exit For
Next Y
End With
End Sub
Maybe you can elaborate a bit more why you want to use named ranges and what you wish to achieve with them that you cannot achieve with the above code as is.
Update:
Miqi180 made me aware that there might be a performance difference when avoiding Offset by directly referencing the cells instead. So, I staged a small performance test on my system (Office 2016, 64-bit) to test this assumption. Apparently, there is a major performance difference of ~14% (comparing the average of 10 iterations using Offset and another 10 iterations avoiding it).
This is the code I used to test the speed difference. Please do let me know if you believe that this setup is flawed:
Option Explicit
' Test whether you are using the 64-bit version of Office.
#If Win64 Then
Declare PtrSafe Function getTickCount Lib "kernel32" Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
#Else
Declare Function getTickCount Lib "kernel32" Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
#End If
Public Sub SpeedTestDirect()
Dim i As Long
Dim ws As Worksheet
Dim dttStart As Date
Dim startTime As Currency, endTime As Currency
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set ws = ThisWorkbook.Worksheets(1)
ws.Cells.Delete
dttStart = Now
getTickCount startTime
For i = 1 To 1000000
ws.Cells(i, 1).Value2 = 1
ws.Cells(i, 2).Value2 = 1
ws.Cells(i, 3).Value2 = 1
ws.Cells(i, 4).Value2 = 1
ws.Cells(i, 5).Value2 = 1
ws.Cells(i, 6).Value2 = 1
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
getTickCount endTime
Debug.Print "Runtime: " & endTime - startTime, Format(Now - dttStart, "hh:mm:ss")
End Sub
Public Sub SpeedTestUsingOffset()
Dim i As Long
Dim ws As Worksheet
Dim dttStart As Date
Dim startTime As Currency, endTime As Currency
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set ws = ThisWorkbook.Worksheets(1)
ws.Cells.Delete
dttStart = Now
getTickCount startTime
For i = 1 To 1000000
ws.Cells(i, 1).Offset(0, 0).Value2 = 1
ws.Cells(i, 1).Offset(0, 1).Value2 = 1
ws.Cells(i, 1).Offset(0, 2).Value2 = 1
ws.Cells(i, 1).Offset(0, 3).Value2 = 1
ws.Cells(i, 1).Offset(0, 4).Value2 = 1
ws.Cells(i, 1).Offset(0, 5).Value2 = 1
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
getTickCount endTime
Debug.Print "Runtime: " & endTime - startTime, Format(Now - dttStart, "hh:mm:ss")
End Sub
Based on this finding the improved code should be (thanks to Miqi180):
Public Sub tmpSO()
Dim WS As Worksheet
Dim X As Long, Y As Long, Z As Long
X = 12
Z = 0
Set WS = ThisWorkbook.Worksheets("Schedule")
With Worksheets("Project Status")
For Y = 4 To WS.Cells(WS.Rows.Count, 2).End(xlUp).Row
If WS.Cells(Y, 2).Font.Bold And WS.Cells(Y, 2).Value2 < 1 Then
WS.Cells(Y, 3).Copy Destination:=.Cells(X, 3)
WS.Cells(Y, 5).Copy Destination:=.Cells(X, 6)
WS.Cells(Y, 6).Copy Destination:=.Cells(X, 7)
WS.Cells(Y, 2).Copy Destination:=.Cells(X, 8)
X = X + 1
Z = Z + 1
' Else
' Y = Y + 1
End If
If Z = 7 Then Exit For
Next Y
End With
End Sub
Yet, it should be noted that the speed can still be very much improved by moving over to (1) copying values only / directly using .Cells(X, 3).Value2 = WS.Cells(Y, 2).Value2 (for example) and (2) furthermore by using arrays instead.
Of course this does not include yet the standard suggestions such as Application.ScreenUpdating = False, Application.Calculation = xlCalculationManual, and Application.EnableEvents = False.
I have a macro with this loop which take a lot of time :
Dim tempval As String
Dim row As Integer, col As Integer
Application.ScreenUpdating = False
For row = 2 To 500 Step 1
tempval = ""
For col = 7 To 15 Step 1
tempval = tempval & Cells(row, col).Value
Cells(row, col).Value = ""
Next col
Cells(row, 7).Value = tempval
For col = 8 To 16 Step 1
tempval = tempval & Cells(row, col).Value
Cells(row, col).Value = ""
Next col
Cells(row, 8).Value = tempval
Next row
Application.ScreenUpdating = True
Range("LibAnglais2:LibAnglais9").Select
Selection.Delete Shift:=xlToLeft
Range("LibFrancais2:LibFrancais9").Select
Selection.Delete Shift:=xlToLeft
There is code, before, and after this loop.
With this loop, the code takes 3 minutes to end. Without, it takes 30s.
But when I click on the excel windows during the loop (You know when a program run, you click, the window become a white blur screen), my macro finish after I clicked and take approximately 45s...
Do you have an idea why ? And how can fix this to have a faster macro ?
Work with a variant array loaded in bulk directly from the worksheet. Use the Join Function for your concatenation (Chr(124) is the 'pipe' character) and return the processed values back to the worksheet en masse.
Option Explicit
Sub sonic()
Dim r As Long, vTMPs() As Variant, vVALs() As Variant
Application.ScreenUpdating = False
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
With Worksheets("Sheet1")
vTMPs = .Range("G2:P500").Value2
ReDim vVALs(LBound(vTMPs, 1) To UBound(vTMPs, 1), LBound(vTMPs, 2) To 2)
For r = LBound(vVALs, 1) To UBound(vVALs, 1)
vVALs(r, 1) = Join(Array(vTMPs(r, 1), vTMPs(r, 2), vTMPs(r, 3), vTMPs(r, 4), _
vTMPs(r, 5), vTMPs(r, 6), vTMPs(r, 7), vTMPs(r, 8)), Chr(124))
vVALs(r, 2) = Join(Array(vTMPs(r, 2), vTMPs(r, 3), vTMPs(r, 4), vTMPs(r, 5), _
vTMPs(r, 6), vTMPs(r, 7), vTMPs(r, 8), vTMPs(r, 9)), Chr(124))
Next r
.Range("G2:P500").ClearContents
.Range("G2").Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
Application.ScreenUpdating = True
'I don't know what the following is supposed to do
.Range("LibAnglais2:LibAnglais9").Delete Shift:=xlToLeft
.Range("LibFrancais2:LibFrancais9").Delete Shift:=xlToLeft
End With
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sometimes VBA needs to process messages to be faster. I don't really know why but if some of my macros act up like that I add a DoEvents line in the loop before the Next and it does wonders. It is not recommended for more complex applications. Here you can find a description of it: https://support.office.com/en-us/article/DoEvents-Function-7af41eca-88e0-470d-adaf-0b3d4c2575b0
So your code would be:
DoEvents
Next row
HTH
Ok guys, so, I found the solution.
In fact, I had a other sub in my code :
Private Sub Worksheet_Change(ByVal Target As Range)
And the code pass on this sub each time a cell was modified.
So I put a :
Application.EnableEvents = False
On my code, and it's work !
Thank's for your help !
EDIT : In fact, the problem is not totally solved... I noticed that the code take a lot of time after saving the worksheet or simply after modifiying the code... Do you have a solution ?
I have worked with basic pivot tables for a few years, however I am getting stuck on something that I think should be fairly simple to solve (ugh).
I would like to format my pivot table in a specific way.
For example, just say I am using the following data:
Client Name Stage Amount Paid Date Paid
Client A Start $70,000 1/10/2015
Client A Middle $50,000 1/11/2015
Client A End $30,000 1/12/2015
Client B Start $50,000 5/11/2015
Client B Middle $30,000 5/11/2015
Client B End $50,000 5/12/2015
Client C Start $10,000 10/12/2015
Client C Middle $20,000 20/12/2015
Client C End $30,000 30/12/2015
I would like to arrange the pivot table so that it looks like this:
Table Example with Correct Formatting
The only way I can almost get it to work is if it looks like this:
PivotTable Example - Not correct formatting
I really need the formatting to be exactly like picture one.
Thanks for any help you may be able to provide.
Answers in excel steps or in VBA code would be awesome :)
I think you cannot have exactly the output that you want with a pivote table. So i wrote a code which create first a pivot table as close as you want. And then other macro which will create the exact format table as you put in the picture.
1) However you have (it could be easily automated) to replace in your row data:
Start by 1
Middle by 2
End by 3
And your row data tittles should be in Sheet1 and start cell A1
Main sub to call all codes: (all codes have to be in the same module. How hope it can help you.
Sub main()
Call PivotTable
Call FinalTable
Call DeleteRow
Call FormatTable
End Sub
Here is the first code that create the pivot table:
Sub PivotTable()
Dim PTCache As PivotCache
Dim PT As PivotTable
'1.CREATE DATA STORAGE UNIT
Set PTCache = ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=Range("A1").CurrentRegion)
'2. ADD WORKSHEET
Worksheets.Add
ActiveSheet.Name = "PivotTable1"
'3.CREATE PIVOT TABLE N*1
Set PT = ActiveSheet.PivotTables.Add( _
PivotCache:=PTCache, _
TableDestination:=Range("A3"))
'4. ENUMERATE PREFERENCES FOR PIVOTE TABLE
With PT
.PivotFields("Client Name").Orientation = xlRowField
.PivotFields("Amount Paid").Orientation = xlRowField
.RowAxisLayout xlTabularRow
End With
'MODIFYING DATA FIELD CALCULATION
With PT.PivotFields("Client Name")
.Subtotals(1) = False
End With
With PT.PivotFields("Date Paid")
.Orientation = xlColumnField
.Caption = " Date Paid"
End With
With PT.PivotFields("Stage")
.Orientation = xlDataField
.Caption = " Stage"
.NumberFormat = "[=1]""Start"";[>2]""End"";""Middle"""
End With
With PT.PivotFields("Amount Paid")
.Orientation = xlDataField
.Function = xlSum
.Caption = " Amount Paid"
End With
Range("C4").Select
Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, _
False, True, False, False)
PT.DisplayErrorString = False
PT.HasAutoFormat = False
PT.PivotSelect "", xlDataAndLabel, True
Selection.Copy
Worksheets.Add
ActiveSheet.Name = "FinalTable"
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Rows(1).Delete
Columns("B").Delete
Columns("I").Delete
Columns("H").Delete
End Sub
To format:
Sub FinalTable()
Dim Nextcell As Double
Dim j As Integer
Lastrow = Sheets("FinalTable").Range("A1").SpecialCells(xlCellTypeLastCell).Row
i = 3
Do Until i = Lastrow
NextProcess i, Nextcell, Lastrow, j
For c = 2 To 7
If j = Lastrow Then Exit Do
If IsEmpty(Cells(i, c)) Then
For j = Nextcell - 1 To i Step -1
If Not IsEmpty(Cells(j, c)) And Not IsEmpty(Cells(j - 1, c)) Then
Range(Cells(j, c), Cells(j - 1, c)).Copy Cells(i, c)
Range(Cells(j, c), Cells(j - 1, c)).ClearContents
Exit For
End If
If Not IsEmpty(Cells(j, c)) Then
Cells(j, c).Copy Cells(i, c)
Cells(j, c).ClearContents
Exit For
End If
If Not IsEmpty(Cells(j - 1, c)) Then
Cells(j - 1, c).Copy Cells(i, c)
Cells(j - 1, c).ClearContents
Exit For
End If
Next j
End If
Next c
StepB = Nextcell - i
i = StepB + i
Loop
i = 2
Do
If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
Rows(i).Delete
i = i - 1
End If
Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row
i = 1 + i
Loop Until i = Lastrow
End Sub
Code to delete the empty rows in your Final Table
Sub DeleteRow()
Dim Lastrow As Long
Dim i As Integer
Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
Rows(i).Delete
i = i - 1
End If
Lastrow = Sheets("FinalTable").Range("A" & Rows.Count).End(xlUp).Row
i = 1 + i
Loop Until i = Lastrow
End Sub
Code to put border in your final table:
Sub FormatTable()
Dim Nextcell As Double
Dim j As Integer
Lastrow = Sheets("FinalTable").Range("G" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If Not IsEmpty(Cells(i, 1)) Then
If Not IsEmpty(Cells(i + 1, 1)) Then
Range(Cells(i, 1), Cells(i, 7)).BorderAround
ElseIf Not IsEmpty(Cells(i + 2, 1)) Then
NextProcess i, Nextcell, Lastrow, j
Range(Cells(i, 1), Cells(Nextcell - 1, 7)).BorderAround
Else
Range(Cells(i, 1), Cells(Lastrow, 7)).BorderAround
End If
End If
Range(Cells(1, 2), Cells(Lastrow, 3)).BorderAround
Range(Cells(1, 4), Cells(Lastrow, 5)).BorderAround
Range(Cells(1, 6), Cells(Lastrow, 7)).BorderAround
Next i
End Sub
The subroutine to find the next client name:
Sub NextProcess(ByVal i As Integer, ByRef Nextcell As Double, ByVal Lastrow As Long, ByRef j As Integer)
Dim Found As Boolean
'Dim j As Integer
Found = False
j = i + 1
Do Until Found = True Or Lastrow = j
If Not IsEmpty(Range("A" & j).Value) Then
Nextcell = Cells(j, 1).Row
Found = True
End If
j = j + 1
Loop
End Sub