range1.value = range2.value Very slow VBA - excel

I'am writing simple code like nextCell.Value = dateJour.Value, were dateJour is a date located in a cell in the workbook.
When I loop (about 100 times) it takes forever because each nextCell.Value = dateJour.Value statement in the AddData procedure takes 0.2 seconds.
Same for .Range(nextCell.Offset(0, 1), nextCell.Offset(0, 8)).Value = wsSaisie.Range("A" & rowNumber, "H" & rowNumber).Value
The AddData procedure is called by fillData procedure and this is where the loop occurs.
It checks if the filled data by the user already exists in the data sheet called "Données". If not it adds data to the sheet (by calling AddData), if yes it modifies the data (by calling ChangeData). It goes/checks line by line because sometimes data has to be added or modified.
Thanks a lot for your help to improve my code !
Public Sub FillData()
Dim wsSaisie As Worksheet
Set wsSaisie = ThisWorkbook.Worksheets("Saisie")
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
Dim lastRow As Long, lastColumn As Long
lastRow = wsSaisie.Range("A:H").Find("*" _
, LookAt:=xlPart _
, LookIn:=xlFormulas _
, SearchOrder:=xlByRows _
, SearchDirection:=xlPrevious).Row
Dim rowKey As String
Dim foundRowNumber As Long
Dim cell As Range
For Each cell In wsSaisie.Range(wsSaisie.Range("I5"), wsSaisie.Range("I" & lastRow))
rowKey = cell.Value
foundRowNumber = DataAlreadyExists(rowKey)
If foundRowNumber = -1 Then
Call AddData(cell.Row)
Else
Call ChangeData(foundRowNumber, cell.Row)
End If
Next cell
End Sub
Public Sub AddData(rowNumber As Long)
Dim wsSaisie As Worksheet
Set wsSaisie = ThisWorkbook.Worksheets("Saisie")
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
Dim dateJour As Range
Set dateJour = wsSaisie.Range("B1")
Dim nextCell As Range
Set nextCell = wsData.Range("A1048576").End(xlUp).Offset(1, 0)
'StartTime = Timer
nextCell.Value = dateJour.Value
'Debug.Print Round(Timer - StartTime, 2)
wsData.Range(nextCell.Offset(0, 1), nextCell.Offset(0, 8)).Value = wsSaisie.Range("A" & rowNumber, "H" & rowNumber).Value
End Sub
Public Sub ChangeData(rowTo As Long, rowFrom As Long)
Dim wsSaisie As Worksheet
Set wsSaisie = ThisWorkbook.Worksheets("Saisie")
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
wsData.Range("G" & rowTo & ":" & "I" & rowTo).Value = wsSaisie.Range("F" & rowFrom & ":" & "H" & rowFrom).Value
End Sub
Public Function DataAlreadyExists(key As String) As Long
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Worksheets("Données")
If Not IsError(Application.Match(key, wsData.Range("K:K"), 0)) Then
DataAlreadyExists = Application.Match(key, wsData.Range("K:K"), 0)
Else
DataAlreadyExists = -1
End If
End Function

Use Value2 instead of Value (ref.)
i.e. in AddData()
nextCell.Value2 = dateJour.Value2
and
nextCell.Offset(0, 1).Resize(1, 8).Value2 = wsSaisie.Cells(rowNumber, 1).Resize(1, 8).Value2
Also, in your DataAlreadyExists() function, you evaluate MATCH twice when data do exist, e.g. consider this
Public Function DataAlreadyExists(key As String) As Long
Dim wsData As Worksheet, resultat as Variant
Set wsData = ThisWorkbook.Worksheets("Données")
resultat = Application.Match(key, wsData.Range("K:K"), 0)
If Not IsError(resultat) Then
DataAlreadyExists = resultat
Else
DataAlreadyExists = -1
End If
End Function

Related

Syntax for If Then SUMIFS

In the code below, I have identified a range (ColRng) in which I want to check each cell - if it is empty, there is a SUMIFS function to perform. It does not work. I know my syntax and logic is horrid, but I can't figure out how to make it work.
Dim ColRng As Range
Dim LastCol As Long
Dim LastRowScenario As Long
Dim x As Long
Dim rngCrit1 As Range
Dim rngCrit2 As Range
Dim rngSum As Range
LastRowScenario = Sheets("Sheet1").Range("Q2").End(xlDown).Row
Set rngCrit1 = Sheets("Sheet1").Range("D2:D" & LastRowScenario)
Set rngCrit2 = Sheets("Sheet1").Range("B2:B" & LastRowScenario)
Set rngSum = Sheets("Sheet1").Range("Q2:Q" & LastRowScenario)
LastCol = Sheets("Summary").Range("B5").End(xlToRight).Column
Set ColRng = Range(LastCol & "6:" & LastCol & "149")
For x = ColRng.Cells.Count To 1 Step -1
With ColRng.Cells(x)
' If the cell is empty, perform a SUMIFS
If IsEmpty(.Value) Then
.Formula = Application.WorksheetFunction.SumIfs(rngSum, rngCrit1, .Range("E" & .Row).Value, rngCrit2, .Range("B" & .Row).Value)
End If
End With
Next x
Your ColRng construction is wrong - try something like this instead:
Dim ColRng As Range
Dim LastCol As Long
Dim LastRowScenario As Long
Dim x As Long
Dim rngCrit1 As Range
Dim rngCrit2 As Range
Dim rngSum As Range, ws As Worksheet, wsSumm As Worksheet
set ws = Sheets("Sheet1")
Set rngSum = ws.Range("Q2:Q" & ws.Range("Q2").End(xlDown).Row)
Set rngCrit1 = rngSum.EntireRow.Columns("D")
Set rngCrit2 = rngSum.EntireRow.Columns("B")
Set wsSumm = Sheets("Summary")
With wsSumm.Range("B5").End(xlToRight).EntireColumn
Set ColRng = wsSumm.Range(.Cells(6), .Cells(149))
End With
For x = ColRng.Cells.Count To 1 Step -1
With ColRng.Cells(x)
' If the cell is empty, perform a SUMIFS
If IsEmpty(.Value) Then
.Formula = Application.SumIfs(rngSum, _
rngCrit1, .EntireRow.columns("E").Value, _
rngCrit2, .EntireRow.columns("B").Value)
End If
End With
Next x

Moving columns containg "Total" at the end of the pivot(after paste special) if the cells of second row contain the word "Total"

' If the cells of second row contain the word "Total" ,I want to copy paste the entire column of that cell to the end of the table.The following code gives no output. Can someone please help me identify my mistake?
enter image description here
Dim PRTSLastRow As Long
Dim PRTSLastCol As Long
Dim ColLtr As String
Dim LastColLtr As String
Dim Total As String
Dim j as Integer
W = ActiveWorkbook.Name
PRTSLastCol = Worksheets("PRTSCarrierCount").Cells(1, Columns.Count).End(xlToLeft).Column
PRTSLastRow = Worksheets("PRTSCarrierCount").Cells(Rows.Count, 1).End(xlUp).Row
j = 1
Workbooks(W).Sheets("PRTSCarrierCount").Activate
For i = 1 To PRTSLastCol
Total = Cells(1, i).Value
If InStr(1, CStr(Total), "Total") > 0 Then
ColLtr = Replace(Cells(1, i).Address(True, False), "$1", "")
LastColLtr = Replace(Cells(1, PRTSLastCol + j).Address(True, False), "$1", "")
Range("ColLtr & 1: & ColLtr & PRTSLastRow").Select
'Columns("ColLtr & : & ColLtr").Select
Selection.Copy
Range("LastColLtr & 1").Select
ActiveSheet.Paste
j = j + 1
End If
Next i
Something like this?
Option Explicit
Sub Thing()
Dim PRTSLastRow As Long
Dim PRTSLastCol As Long
Dim ColLtr As String
Dim LastColLtr As String
Dim Total As String
Dim W As Workbook
Dim i As Long
Dim ws As Worksheet
Set W = ThisWorkbook 'Or ActiveWorkbook
Set ws = W.Worksheets("PRTSCarrierCount")
PRTSLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
PRTSLastCol = GetLastCol(ws, 1)
With ws
For i = 1 To PRTSLastCol
Total = LCase$(.Cells(1, i).Text)
If InStr(1, Total, "total") > 0 Then
ColLtr = Replace(.Cells(1, i).Address(True, False), "$1", "")
.Range(ColLtr & "1:" & ColLtr & PRTSLastRow).Copy .Cells(1, GetLastCol(ws, 1) + 1)
i = i + 1
End If
Next i
End With
End Sub
Public Function GetLastCol(ByVal ws As Worksheet, rowNum As Long) As Long
With ws
GetLastCol = .Cells(rowNum, Columns.Count).End(xlToLeft).Column
End With
End Function
Or with Find
Public Sub Thing2()
Dim PRTSLastRow As Long
Dim PRTSLastCol As Long
Dim ColLtr As String
Dim LastColLtr As String
Dim Total As String
Dim W As Workbook
Dim ws As Worksheet
Dim searchRng As Range
Set W = ThisWorkbook 'Or ActiveWorkbook
Set ws = W.Worksheets("PRTSCarrierCount")
PRTSLastCol = GetLastCol(ws, 1)
Total = "total"
With ws
PRTSLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set searchRng = .Range(.Cells(1, 1), .Cells(1, PRTSLastCol))
Dim gatheredRange As Range
Set gatheredRange = GatherRanges(Total, searchRng, PRTSLastRow)
If Not gatheredRange Is Nothing Then
gatheredRange.Copy .Cells(1, GetLastCol(ws, 1) + 1)
End If
End With
End Sub
Public Function GatherRanges(ByVal Total As String, ByVal searchRng As Range, ByVal PRTSLastRow As Long) As Range
Dim foundCell As Range
Set foundCell = searchRng.Find(Total)
If foundCell Is Nothing Then
MsgBox "Search term not found"
End
End If
Dim firstfoundCellAddress As String
firstfoundCellAddress = foundCell.Address
Dim gatheredRange As Range
Set gatheredRange = foundCell.Resize(PRTSLastRow, 1)
Do
Set foundCell = searchRng.FindNext(foundCell)
Set gatheredRange = Union(gatheredRange, foundCell.Resize(PRTSLastRow, 1))
Loop While firstfoundCellAddress <> foundCell.Address
Set GatherRanges = gatheredRange
End Function
Reference:
https://excelmacromastery.com/excel-vba-find/

Build hierarchy type presentation of data in Excel

I try to convert my excel data to tree data using vba.
Sub MakeTree()
Dim r As Integer
' Iterate through the range, looking for the Root
For r = 1 To Range("Data").Rows.Count
If Range("Data").Cells(r, 1) = "Root" Then
DrawNode Range("Data").Cells(r, 2), 0, 0
End If
Next
End Sub
Sub DrawNode(ByRef header As String, ByRef row As Integer, ByRef depth As Integer)
'The DrawNode routine draws the current node, and all child nodes.
' First we draw the header text:
Cells(Range("Destination").row + row, Range("Destination").Column + depth) = header
Dim r As Integer
'Then loop through, looking for instances of that text
For r = 1 To Range("Data").Rows.Count
If Range("Data").Cells(r, 1) = header Then
'Bang! We've found one! Then call itself to see if there are any child nodes
row = row + 1
DrawNode Range("Data").Cells(r, 2), row, depth + 1
End If
Next
End Sub
My excel data like this,
I try to convert tree data like this by using my vba code.
But above code didn't work for me.
Anyone suggest me ?
Thanks
Try this, it makes use of a temporary PivotTable...
Option Explicit
Sub TestMakeTree()
Dim wsData As Excel.Worksheet
Set wsData = ThisWorkbook.Worksheets.Item("Sheet1")
Dim rngData As Excel.Range
Set rngData = wsData.Range("Data") '<----------------- this differs for me
Dim vTree As Variant
vTree = MakeTreeUsingPivotTable(ThisWorkbook, rngData)
'* print it out next to data, you'd choose your own destination
Dim rngDestinationOrigin As Excel.Range
Set rngDestinationOrigin = wsData.Cells(rngData.Row, rngData.Columns.Count + 2)
rngDestinationOrigin.Resize(UBound(vTree, 1), UBound(vTree, 2)) = vTree
End Sub
Function MakeTreeUsingPivotTable(ByVal wb As Excel.Workbook, ByVal rngData As Excel.Range) As Variant
Dim oPivotCache As PivotCache
Set oPivotCache = CreatePivotCache(wb, rngData)
Application.ScreenUpdating = False
Dim wsTemp As Excel.Worksheet
Set wsTemp = wb.Worksheets.Add
Dim oPivotTable As Excel.PivotTable
Set oPivotTable = CreatePivotTableAndAddColumns(wsTemp, oPivotCache, rngData.Rows(1))
oPivotTable.RowAxisLayout xlOutlineRow
oPivotTable.ColumnGrand = False
oPivotTable.RowGrand = False
MakeTreeUsingPivotTable = oPivotTable.TableRange1.Value2
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Function CreatePivotTableAndAddColumns(ByVal wsDestination As Excel.Worksheet, _
ByVal oPivotCache As Excel.PivotCache, ByVal rngColumnHeaders As Excel.Range)
Const csTEMP_PIVOT_NAME As String = "TempMakeTreePivot"
Dim sThirdRowDown As String
sThirdRowDown = "'" & wsDestination.Name & "'!R3C1"
Dim oPivotTable As Excel.PivotTable
Set oPivotTable = oPivotCache.CreatePivotTable(TableDestination:=sThirdRowDown, _
TableName:=csTEMP_PIVOT_NAME, DefaultVersion:=xlPivotTableVersion15)
Dim rngColumnLoop As Excel.Range, lLoop As Long
For Each rngColumnLoop In rngColumnHeaders.Cells
lLoop = lLoop + 1
With oPivotTable.PivotFields(rngColumnLoop.Value2)
.Orientation = xlRowField
.Position = lLoop
End With
Next rngColumnLoop
Set CreatePivotTableAndAddColumns = oPivotTable
End Function
Function CreatePivotCache(ByVal wb As Excel.Workbook, ByVal rngData As Excel.Range)
Dim sFullyQualified As String
sFullyQualified = "'" & rngData.Parent.Name & "'!" & rngData.Address
Dim oPivotCache As PivotCache
Set oPivotCache = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
sFullyQualified, Version:=xlPivotTableVersion15)
Set CreatePivotCache = oPivotCache
End Function
another proposal
Sub aaargh()
Dim o(3)
Set ws1 = Sheet1 ' source sheet to adapt
Set ws2 = Sheet3 ' target sheet to adapt
With ws1
nv = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1:C" & nv).Sort key1:=.Range("a1"), order1:=xlAscending, _
key2:=.Range("B1"), order2:=xlAscending, _
key3:=.Range("C1"), order3:=xlAscending, _
Header:=xlYes
ctrl = 0
For i = 2 To nv
fl = False
For j = 1 To 3
If o(j) <> .Cells(i, j) Or fl = True Then
ctrl = ctrl + 1
o(j) = .Cells(i, j)
ws2.Cells(ctrl, j) = o(j)
fl = True
End If
Next j
ctrl = ctrl + 1
ws2.Cells(ctrl, 4) = .Cells(i, 4)
Next i
End With
End Sub

Which the fastest way to sum two range?

I need summ column values from multiple workbooks and worksheets in single worksheet. If i'm trying do it like this:
While targetCell.Row <> LastRow
targetCell.Value = targetCell.Value + sourseCell.Value
Set sourseCell = sourseSheet.Cells(sourseCell.Row + 1, sourseCell.Column)
Set targetCell = targetSheet.Cells(targetCell.Row + 1, targetCell.Column)
Wend
It takes too much time(Hours!!!).
Like this:
targetSheet.Range("D14:BJ" & LastRow).Value = targetSheet.Range("D14:BJ" & LastRow).Value + sourseSheet.Range("D14:BJ" & LastRow).Value
I'm sometimes have error type mismatch
Full code:
For Each foldername In subFolders
If foldername <> ThisWorkbook.path Then
filePath = foldername & fileName
Dim app As New Excel.Application
app.Visible = False
Dim book As Excel.Workbook
Set book = app.Workbooks.Add(filePath)
For Each targetSheet In ActiveWorkbook.Worksheets
Dim sourseSheet As Worksheet
Set sourseSheet = book.Worksheets(targetSheet.Name)
Call CopyColumn(targetSheet, sourseSheet, LastRow)
Next
book.Close SaveChanges:=False
app.Quit
Set app = Nothing
End If
Next
Sub CopyColumn(targetSheet, sourseSheet As Worksheet, LastRow As Integer)
Dim sourseCell, targetCell As Range
Set targetCell = targetSheet.Cells(14,"D")
Set sourseCell = sourseCell.Cells(14,"CH")
While targetCell.Row <> LastRow
targetCell.Value = targetCell.Value + sourseCell.Value
Set sourseCell = sourseSheet.Cells(sourseCell.Row + 1, sourseCell.Column)
Set targetCell = targetSheet.Cells(targetCell.Row + 1, targetCell.Column)
Wend
End Sub
Copying the ranges to Variant arrays is quite fast. Your subroutine amended and commented below:
Sub CopyColumn(targetSheet As Worksheet, sourseSheet As Worksheet, LastRow As Long)
' LastRow as Integer will give an error for rows > 32,767, use Long instead
' Check the syntax: sourseCell, targetCell as Range means:
' sourceCell as Variant, targetCell as Range. We should include
' "as Range" after each variable declaration if we want it to be a Range
Dim sourseCell As Range, targetCell As Range
Dim lCount As Long
Dim vTarget, vSource
' I kept the names targetCell, sourseSheet, but turned them to ranges
' You might want to change sourseSheet to sourceSheet
With targetSheet
Set targetCell = .Range(.Cells(14, "D"), .Cells(LastRow, "D"))
End With
' I assume you mean sourceSheet instead of sourceCell,
' in your original code?
With sourseSheet
Set sourseCell = .Range(.Cells(14, "CH"), .Cells(LastRow, "CH"))
End With
vTarget = targetCell.Value2
vSource = sourseCell.Value2
' If there is a change you do not have numeric values
' this needs error trapping
For lCount = LBound(vTarget, 1) To UBound(vTarget, 1)
vTarget(lCount, 1) = vTarget(lCount, 1) + vSource(lCount, 1)
Next lCount
targetCell.Value = vTarget
End Sub
Testing:
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub test_copy_column()
Dim targetSheet As Worksheet, sourseSheet As Worksheet, LastRow As Long, _
tick As Long
' Maybe change sourseSheet to sourceSheet :)
tick = GetTickCount ' Clock count
Set targetSheet = Sheet1
Set sourseSheet = Sheet1
LastRow = 50000 ' I inputted random numbers for testing
CopyColumn targetSheet, sourseSheet, LastRow
MsgBox "Time to copy: " & GetTickCount - tick & " milliseconds"
End Sub
Result:
Relevant SO question here
I hope that helps!
for fast non-VBA solution, open all workbooks and insert following formula into a helper sheet:
=first_cell_from_source_workbook + first_cell_from_target_workbook + ...
copy the formula to cover whole range you need to cover.
copy & paste-special-as-values to target range if you wish to replace the original values in target range..
each time you wish to recalculate, make sure all source workbooks are open.

Concatenate unique cell values in every row

How can I concatenate unique cell values in every row to adapt in the code below. Removing duplicate values in a cell. Result after macro is the second image.
Sub Concatenar()
Dim myRange As Range
Dim c As Long
Dim r As Long
Dim txt As String
Set myRange = Application.InputBox("Selecione a primeira e a última célula:", Type:=8)
For r = 1 To myRange.Rows.Count
For c = 1 To myRange.Columns.Count
If myRange(r, c).Text <> "" Then
txt = txt & myRange(r, c).Text & vbLf
End If
Next
If Right(txt, 1) = vbLf Then
txt = Left(txt, Len(txt) - 1)
End If
myRange(r, 1) = txt
txt = ""
Next
Range(myRange(1, 2), myRange(1, myRange.Columns.Count)).EntireColumn.Delete
End Sub
This does what you want, I believe. It pastes/tranposes the values to a temporary workbook, uses RemoveDuplicates to trim them down, and Join to munge them all together. It then pastes the munged values back into column A of the original workbook and deletes the other columns.
Because of the destructive nature of this code, you must test it on a copy of your data:
Sub CrazyPaste()
Dim wsSource As Excel.Worksheet
Dim rngToConcat As Excel.Range
Dim wbTemp As Excel.Workbook
Dim wsPasted As Excel.Worksheet
Dim rngPasted As Excel.Range
Dim i As Long
Dim LastRow As Long
Dim Results() As String
Set wsSource = ActiveSheet
Set rngToConcat = wsSource.UsedRange
Set wbTemp = Workbooks.Add
Set wsPasted = wbTemp.Worksheets(1)
wsSource.UsedRange.Copy
wsPasted.Range("A1").PasteSpecial Transpose:=True
Set rngPasted = wsPasted.UsedRange
ReDim Results(1 To rngPasted.Columns.Count)
For i = 1 To rngPasted.Columns.Count
If WorksheetFunction.CountA(rngPasted.Columns(i)) = 0 Then
Results(i) = ""
Else
rngPasted.Columns(i).RemoveDuplicates Columns:=1, Header:=xlNo
LastRow = Cells(wsPasted.Rows.Count, i).End(xlUp).Row
Results(i) = Replace(Join(Application.Transpose(rngPasted.Columns(i).Resize(LastRow, 1)), vbCrLf), _
vbCrLf & vbCrLf, vbCrLf)
End If
Next i
With wsSource
.Range("A1").Resize(i - 1, 1) = Application.Transpose(Results)
.Range(.Cells(1, 2), .Cells(1, .Columns.Count)).EntireColumn.Delete
wbTemp.Close False
End With
End Sub
In my limited testing, the only situation where this might yield unwanted results is when a cell in the first column is blank, but there's other data in that row. The resulting cell would then start with a blank.

Resources