I am using Excel interop to create excel workbooks from my query results. When there are thousands of records it takes a long time for the workbook to be generated. The below code is a sample of how I am populating the cells.
RowNo = 1
For i = 1 To 4000
ColNo = 1
For j = 1 To 5
Dim cell As excel.Range = ws.Cells(RowNo, ColNo)
Dim value = j
cell.Value = value
ColNo = ColNo + 1
Next
RowNo = RowNo + 1
Next
For the above code to run it takes more than a minute. How can I optimize it?
Found the answer. You can write data to an array and then write the array to the excel range rather than writing the data cell by cell. See http://www.clear-lines.com/blog/post/Write-data-to-an-Excel-worksheet-with-C-fast.aspx
private static void WriteArray(int rows, int columns, Worksheet worksheet)
{
var data = new object[rows, columns];
for (var row = 1; row <= rows; row++)
{
for (var column = 1; column <= columns; column++)
{
data[row - 1, column - 1] = "Test";
}
}
var startCell = (Range)worksheet.Cells[1, 1];
var endCell = (Range)worksheet.Cells[rows, columns];
var writeRange = worksheet.Range[startCell, endCell];
writeRange.Value2 = data;
}
Related
I am a beginner with VBA and am having a hard time building a table in PPT with excel data that includes merged cells. Currently, my code loops through my excel range and brings over rows of data (unmerged). I would like for my macro to loop through column B, identify rows that are merged, then for each set of merged rows, copy over the associate rows to a ppt table.
OR
Since my macro is already bringing over the rows, is there a way to go through each table in the slides and merge cells with the same value?
Current code:
Dim count i, j as integer: count = 3
Dim rng as Range
Dim PPRow as integer: Maxheight=380
SlideNo = SlideNo + 3
j = SlideNo
i=Application.WorksheetFunction.CountA(Sheets("Sheet1").Range("B10:B80"))
If i >= 1 Then
PPApp.ActiveWindow.View.GotoSlide SlideNo
For f = 1 To (i +1)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,1).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 0)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,2).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 1)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,3).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 2)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,4).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 3)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,5).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 4)
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.cell(PPRow,6).Shape.TextFrame.TextRange.Text = Sheets("Sheet2").Range("B10").Offset(o, 5)
o = o +1
If row < i And PPPres.Slides(SlideNo).Shapes("tblTable1").Height > MaxHeight Then
Module2.InsertDuplicateSlide (SlideNo)
SlideNo = SlideNo + 1
PPApp.ActiveWindow.View.GotoSlide SlideNo
MaxHeight = 380
For Row2 = 3 To PPPres.Slides(SlideNo).Shapes("tblTable1").Table.Rows.Count
PPPres.Slides(SlideNo).Shapes("tblTable1").Table.Rows(2).Delete
Next Row2
PPRow = 2
Else: PPPres.Slides(SlideNo).Shapes("tblTable1").Table.Rows.Add
PPRow = PPRow +1
End if
Next
End if
End Function
Thanks in advance
I'm trying to get a set of input data and split them out of various cells once it hits a text limit
For example, the amount of characters in cell A1 is 100
I want to split it such that A1, B1, C1, D1 etc. all contains 10 character each
The input of the 100 characters is coming from a loop that combines entries of multiple cells together
I am able to write a loop that can combine the values into 1 cell
But I'm finding trouble to write it such that Cell A1 should only contain 10 characters before proceeding to Cell B1 to populate the next 10 characters etc.
Sub getReport()
Dim com As New cls_common_funct
Dim result, report, ws As Worksheet
Dim lastrw, length, count, i As Long
Dim exp, strategy As String
Dim firstFlag As Boolean
Set ws = Worksheets(ActiveSheet.Name)
Set result = Worksheets("result")
result.Cells.ClearContents
lastrw = com.FindLastRow_WithinColumn(ws.Name, "A")
exp = ""
firstFlag = False
For i = 3 To lastrw
strategy = ws.Cells(i, 1)
If firstFlag = False Then
exp = strategy
firstFlag = True
Else
exp = exp & ", " & strategy
End If
Next
result.Select
result.Range("A1") = exp
How about this one?
Sub stringmanipulation()
Dim length As Long, count As Long, i As Long
length = Len(Range("A1")) 'gets length of range
count = Application.WorksheetFunction.RoundUp(length / 10, 0) - 1
For i = 1 To count
Cells(1, i + 1) = Left(Range("A1"), 10)
Range("A1") = Right(Range("A1"), length - 10)
length = length - 10
Next i
Cells(1, i + 1) = Range("A1")
Range("A1").ClearContents
End Sub
I start using structured table with VBA code, but here I face a problem which I do not manage by myself.
I have a structured table in which I loop through 1 column and need to get values from other columns depending on some criteria:
if the cells value is "Finished"
then I take 3 dates (dateScheduled, dateRelease and dateReady) from 3 other columns and perform some calculations and tests based on these dates
the problem is that I can get the values of the date columns (they are well formatted and have values in it), so none of the next actions triggered by the first if is working.
Here is part of the whole code of my macro, I hope this is sufficient to figure out what is wrong.
For Each valCell In Range("thisIsMyTable[Task Status]").Cells
If valCell = "Finished" Then
dateScheduled = Range("thisIsMyTable[End Date]").Cells
dateRelease = Range("thisIsMyTable[Release Date]").Cells
dateReady = Range("thisIsMyTable[Date Ready]").Cells
totalFinishCat = totalFinishCat + 1
daysToFinished = daysToFinished + DateDiff("d", dateReady, dateRelease)
If Range("thisIsMyTable[Time Spent]").Cells = "" Then
timeTotalFinished = timeTotalFinished + Range("thisIsMyTable[Time estimate]").Cells + Range("thisIsMyTable[Extra hours]").Cells
Else
timeTotalFinished = timeTotalFinished + Range("thisIsMyTable[Time Spent]").Cells
End If
If dateRelease >= dateStartReport Then
monthFinished = monthFinished + 1
timeMonthFinished = timeMonthFinished + Range("thisIsMyTable[Time Spent]").Cells
daysToFinishedMonth = daysToFinishedMonth + DateDiff("d", dateReady, dateRelease)
If dateRelease > dateScheduled Then
afterDue = afterDue + 1
diff = DateDiff("d", dateScheduled, dateRelease)
afterDay = afterDay + diff
Else
beforeDue = beforeDue + 1
diff = DateDiff("d", dateRelease, dateScheduled)
beforeDay = beforeDay + diff
End If
End If
End If
Next valCell
I have tried out by adding .value or .value2 like so:
dateScheduled = Range("thisIsMyTable[End Date]").Cells.value
or
dateScheduled = Range("thisIsMyTable[End Date]").Cells.value2
but it does not work better. I have checked by adding .select like so:
dateScheduled = Range("thisIsMyTable[End Date]").Cells.select
and this will select the entire column, not the cells as I expect. So it appears that my method to just get the cells value is not appropriate.
Any help is welcome
If you create a lookup of column names to column number, you can loop through the rows of the table and extract the value using Range(1, columnno). For example
Option Explicit
Sub MyMacro()
Dim ws As Worksheet, tb As ListObject
Dim r As ListRow
Dim sStatus As String, dEnd As Date, dRelease As Date, dReady As Date
' table
Set ws = Sheet1
Set tb = ws.ListObjects("thisIsMyTable")
' lookup column name to number
Dim dict As Object, c As ListColumn
Set dict = CreateObject("Scripting.Dictionary")
For Each c In tb.ListColumns
dict.Add c.Name, c.Index
Next
' scan table rows
For Each r In tb.ListRows
sStatus = r.Range(1, dict("Task Status"))
If sStatus = "Finished" Then
dEnd = r.Range(1, dict("End Date"))
dRelease = r.Range(1, dict("Release Date"))
dReady = r.Range(1, dict("Date Ready"))
Debug.Print dEnd, dRelease, dReady
End If
Next
End Sub
I have a code that sorts through thousands of lines in a spreadsheet and when it finds a row that has a specific match in two different columns, it returns a value in a third column. However this UDF is used thousands of times and with each running thousands of loops, its very slow. Is there a way to speed up or make this more efficient?
Dim SearchSheet As Worksheet
Dim PN As Integer
Dim MdlCol As Integer
Dim Mdl As String
Dim Result As Integer
Dim FinalRow As Integer
Dim i As Integer
Application.Volatile True
Select Case True
Case Number < WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1A"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 5
Mdl = "1A"
Result = 30
Case Number < WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1B"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 6
Mdl = "1B"
Result = 30
Case Number < WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1C"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 7
Mdl = "1C"
Result = 30
Case Number >= WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1A"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 18
Mdl = "-1A"
Result = 80
Case Number >= WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1B"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 19
Mdl = "-1B"
Result = 80
Case Number >= WorksheetFunction.CountA(Sheet2.Range("A:A")) And Model = "1C"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 20
Mdl = "-1C"
Result = 80
End Select
FinalRow = WorksheetFunction.CountA(SearchSheet.Range("A:A")) + 10
For i = 2 To FinalRow
If SearchSheet.Cells(i, PN) = PartNumber And SearchSheet.Cells(i, MdlCol) = Mdl Then
If SearchSheet.Cells(i, Result).Value = "X" Then
CalibrationRequired = "Y"
Else
CalibrationRequired = SearchSheet.Cells(i, Result).Value
End If
Exit For
End If
Next i
End Function ```
I would suggest:
put LastARow=WorksheetFunction.CountA(SearchSheet.Range("A:A")) once at the start and re-use LastARow rather than repeating the COUNTA many times.
Instead of looping down to final row and looking at each cell in turn, get all the data into a variant array and loop on that
Avoid the VBE UDF slowdown bug by initiating calculation from VBA
I have the following script that works well in google docs --> sheets. It doesn't work well with a lot of rows. I am guessing because of the array that keeps getting bigger that tracks the values.
I need a script I can run in MS EXCEL that will remove rows that have a duplicate value in a column. (Unless the column is "")
Google docs script that works for small files:
function removeDuplicates()
{
var s = SpreadsheetApp.getActiveSheet();
var c = Browser.inputBox("Please", "Type in the column name (e.g.: A, B, etc.)", Browser.Buttons.OK_CANCEL);
var r, v;
var aValues = [];
try
{
if(c != "cancel")
{
r = 2; // first row is row two
while (r <= s.getLastRow())
{
v = s.getRange(c + r).getValue();
if(v != "")
{
if(aValues.indexOf(v) == -1)
{
aValues.push(v);
}
else
{
s.deleteRow(r);
continue;
}
}
r++;
}
Browser.msgBox("Duplicates removed!");
}
} catch (e) {Browser.msgBox("Error Alert:", e.message, Browser.Buttons.OK);}
}
Any help would be appreciated.
Here is something that seems to fit the bill.
Sub dedupe_ignore_blanks()
Dim r As Long, v As Long, vVALs As Variant, sCOL As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With ActiveSheet.Cells(1, 1).CurrentRegion
sCOL = "B"
sCOL = Application.InputBox("Type in the column name (e.g.: A, B, etc.)", _
"Please", sCOL, 250, 75, "", , 2)
If CBool(Len(sCOL)) And sCOL <> "False" Then
For r = .Rows.Count To 2 Step -1
If Application.CountIf(.Columns(sCOL), .Cells(r, sCOL).Value) > 1 Then _
.Rows(r).EntireRow.Delete
Next r
End If
End With
FallThrough:
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I gathered from your code snippet that you had a header row in the data row 1. The Application.CountIF does not count blank cells.