Related
I am new to stackoverflow.com and VBA. I have been searching the web for a VBA that will allow me to copy data from sheet 1 that I input and then paste into sheet 2 based off the a cell value match. Once it is copied, it would then clear the data on Sheet 1 without delete the rows.
I work in a call center, and this would be to update equipment based on the desk it is located at.
So I am hoping that once I input all the data into the fields on sheet 1, I can click an activex button and it will search for the desk number on sheet 2 in column A and then update the row (B:Q) with the data from sheet 1.
I have seen some VBA that will copy the data but it only copies to the next empty row of cells.
Here is the code that I have found but is just not right.
Sub MoveRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A5:Q5" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = ("A5") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Any help would be great!
Thanks.
Something like the code below? I assumed the desk number are on column A sheet1 starting at row 2. You will need to adjust the end rows for both sheet though.
Sub MoveRowBasedOnCellValue()
Dim s1 As Sheet1
Set s1 = Sheet1
Dim s2 As Sheet2
Set s2 = Sheet2
Dim s1StartRow As Integer
Dim s1EndRow As Integer
Dim s2StartRow As Integer
Dim s2EndRow As Integer
s1StartRow = 2
s1EndRow = 8
s2StartRow = 2
s2EndRow = 10
Application.ScreenUpdating = False
For i = s1StartRow To s1EndRow
For j = s2StartRow To s2EndRow
If s1.Cells(i, 1) = s2.Cells(j, 1) Then
s1.Range("B" & i & ":Q" & i).Copy
s2.Cells(j, 2).PasteSpecial xlPasteAll
Application.CutCopyMode = False
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
I want to write some VBA code that will count how many sets of "contiguous rows of Ts" there are in a single column in a worksheet. However I want such data sets to only be counted if there are more than 500 rows after the final T in a set that contain F values. For example, if T values are found at rows 500-510, then rows 511- 1010 would have to contain F values for one to be added to the count. If another T is encountered before reaching 1010, then the code would "reset" the 500 row counter and begin again.
row 1 - 1000 = F
row 1001 - 1011 = T
row 1012 - 1600 = F
row 1601 - 1611 = T
row 1612 - 3000 = F
In this case the counter would display 2
Conversely:
row 1 - 1000 = F
row 1001 - 1011 = T
row 1012 - 1400 = F
row 1401 - 1411 = T
row 1412 - 3000 = F
The counter would only display 1 as the Ts in cluster 1001-1011 are <500 rows within cluster 1401-1411.
I am also aware that in some scenarios there may be a set of Ts that are within 500 rows of the end of overall data. These would also need to be ignored from the count (I.e. using the example above, if Ts occurred a 2,700 - 2710, in a set of data with 3,000 rows, these would need to be ignored from the count). Similarly I would need to exclude rows 1-500 from the count also.
I don't know if this would be possible or even how to begin writing the code for this, so any assistance will be greatly appreciated. Excerpt of data:
F
F
F
F
F
F
F
F
F
T
T
T
T
T
F
F
F
F
F
F
F
F
This is going to be added to a much larger macro which then goes to filter out all rows containing Ts and deleting them. However I want to perform the count of contiguous Ts first before taking this step.
Code for rest of macro (This code is called by another macro which takes the values generated and pastes them into a master file):
Sub RollMap_Ensocoat(Wb As Workbook)
Dim ws As Worksheet
Dim Rng As Range, Cell As Range
Dim finalRow As Long
'Set name of first sheet in spreadsheet to "1"
With Wb.Sheets(1)
.Name = "1"
End With
'Code to delete all rows that contain a "T" in column G" (Indicating a tab was fired and thus is waste)
With Sheets("1")
finalRow = .Range("G" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
With .Range("G4:G" & finalRow)
.AutoFilter Field:=1, Criteria1:="T"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
'Code to calculate all the important values of each reel that will be pasted into the master report.
End With
Set ws = Wb.Sheets.Add(After:=Sheets(Wb.Sheets.Count))
With ws
.Range("A3").FormulaR1C1 = "=MAX('1'!C)"
.Range("B3").Formula = "=A3*I3"
.Range("C3").Formula = "=SUBTOTAL(109,'1'!B4:B10000)"
.Range("D3").Formula = "=SUBTOTAL(109,'1'!C4:C10000)"
.Range("E3").Formula = "=SUBTOTAL(109,'1'!D4:D10000)"
.Range("F3").Formula = "=SUBTOTAL(109,'1'!E4:E10000)"
.Range("G3").Formula = "=SUBTOTAL(109,'1'!F4:F10000)"
.Range("H3").Formula = "=SUM(C3:G3)"
.Range("I3").Formula = "='1'!A1"
.Range("J3").Formula = "=H3/(A3*I3)"
.Range("K3").Value = "0.21"
.Range("L3").Value = Wb.Name
.Range("M3").Formula = "=Left(L3, Len(L3) - 4)"
.Range("M3").Copy
.Range("M3").PasteSpecial xlPasteValues
.Range("N3").Formula = "=RIGHT(M3, 11)"
.Range("O3").Formula = "=LEFT(N3,2) & ""/"" & MID(N3,3,2) & ""/20"" & MID(N3,5,2)"
.Range("P3").Formula = "=MID(N3,8,2)& "":"" & MID(N3,10,2)"
.Range("Q3").Formula = "=Left(L3, Len(L3) - 16)"
.Range("A3:Q3").Copy
.Range("A3:Q3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A3:Q3").Copy
End With
End Sub
Code with Tim's suggested additions:
Sub Populate_Ensocoat()
On Error GoTo eh
Dim MyBook As String
Dim Wb As Workbook
Dim strFolder As String
Dim strFil As String
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim xCount As Long
Dim SourceRang1 As Range
Dim FillRange1 As Range
'Code to improve performance
Application.ScreenUpdating = False
Application.EnableEvents = False
'Code to Prompt user to select file location
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
strFolder = .SelectedItems(1)
Err.Clear
End With
'Code to count how many files are in folder and ask user if they wish to continue based on value counted
strFil = Dir(strFolder & "\*.csv*")
Do While strFil <> ""
xCount = xCount + 1
strFil = Dir()
Loop
If MsgBox("You have selected " & xCount & " files. Are you sure you wish to continue?", vbYesNo) = vbNo Then GoTo eh
'Code to Start timer
StartTime = Timer
'Code to make final report sheet visible and launch sheet hidden
Sheet1.Visible = True
Sheet1.Activate
Sheets("Sheet3").Visible = False
'declaring existing open workbook's name
MyBook = ActiveWorkbook.Name
'Code to cycle through all files in folder and paste values into master report
strFil = Dir(strFolder & "\*.csv*")
Do While strFil <> vbNullString
Set Wb = Workbooks.Open(strFolder & "\" & strFil)
Call RollMap_Ensocoat(Wb)
Workbooks(MyBook).Activate
ActiveSheet.Paste
Selection.HorizontalAlignment = xlCenter
ActiveCell.Offset(1).Select
Wb.Close SaveChanges:=False
strFil = Dir
Loop
'Formatting of values in final report
Range("B:I").NumberFormat = "#,##0"
Range("J:K").NumberFormat = "0.000"
Range("L:L").NumberFormat = "0.00"
Range("P:P").NumberFormat = "dd/MM/yyyy"
Range("Q:Q").NumberFormat = "hh:mm"
'Code to add header data to report (i.e. total files, name of person who created report, date and time report was created)
Range("Y2").Value = Now
Range("H2").Value = "# of Files Reported on: " & xCount
Range("P2").Value = Application.UserName
'Re-enabling features disabled for improved macro performance that are now needed to display finished report
Application.EnableEvents = True
Application.ScreenUpdating = True
'Code to refresh sheet so that graphs display properly
ThisWorkbook.RefreshAll
'Code to automatically save report in folder where files are located. Overrides warning prompting user that file is being saved in Non-macro enabled workbook.
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strFolder & "\" & "Summary Report", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'Code to display message box letting user know the number of files reported on and the time taken.
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "Operation successfully performed on " & xCount & " files in " & SecondsElapsed & " seconds." & vbNewLine & vbNewLine & "Report created at location: " & Application.ActiveWorkbook.FullName, vbInformation
Done:
Exit Sub
eh:
MsgBox "No Folder Selected. Please select re-select a board grade"
End Sub
Sub RollMap_Ensocoat(Wb As Workbook)
Dim ws As Worksheet
Dim finalRow As Long
'Set name of first sheet in spreadsheet to "1"
With Wb.Sheets(1)
.Name = "1"
.Range("H1").Formula = "=TCount(G3:G10000)"
End With
'Code to delete all rows that contain a "T" in column G" (Indicating a tab was fired and thus is waste)
With Sheets("1")
finalRow = .Range("G" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
With .Range("G4:G" & finalRow)
.AutoFilter Field:=1, Criteria1:="T"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
'Code to calculate all the important values of each reel that will be pasted into the master report.
End With
Set ws = Wb.Sheets.Add(After:=Sheets(Wb.Sheets.Count))
With ws
.Range("A3").FormulaR1C1 = "=MAX('1'!C)"
.Range("B3").Formula = "=A3*I3"
.Range("C3").Formula = "=SUBTOTAL(109,'1'!B4:B10000)"
.Range("D3").Formula = "=SUBTOTAL(109,'1'!C4:C10000)"
.Range("E3").Formula = "=SUBTOTAL(109,'1'!D4:D10000)"
.Range("F3").Formula = "=SUBTOTAL(109,'1'!E4:E10000)"
.Range("G3").Formula = "=SUBTOTAL(109,'1'!F4:F10000)"
.Range("H3").Formula = "=SUM(C3:G3)"
.Range("I3").Formula = "='1'!A1"
.Range("J3").Formula = "=H3/(A3*I3)"
.Range("K3").Value = "0.21"
.Range("L3").Value = Wb.Name
.Range("M3").Formula = "=Left(L3, Len(L3) - 4)"
.Range("M3").Copy
.Range("M3").PasteSpecial xlPasteValues
.Range("N3").Formula = "=RIGHT(M3, 11)"
.Range("O3").Formula = "=LEFT(N3,2) & ""/"" & MID(N3,3,2) & ""/20"" & MID(N3,5,2)"
.Range("P3").Formula = "=MID(N3,8,2)& "":"" & MID(N3,10,2)"
.Range("Q3").Formula = "=Left(L3, Len(L3) - 16)"
.Range("R3").Formula = "='1'!H1"
.Range("A3:R3").Copy
.Range("A3:R3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A3:R3").Copy
End With
End Sub
Function TCount(rng As Range)
Const GAP_SIZE As Long = 5 '<< low number for testing...
Dim rv As Long, i As Long, fCount As Long, n As Long, d
Dim haveT As Boolean
rv = 0
d = rng.Value
n = UBound(d, 1)
fCount = 0
If n > GAP_SIZE Then
For i = 1 To n
If d(i, 1) = "T" Then
fCount = 0
haveT = True
Else
fCount = fCount + 1
If fCount = GAP_SIZE And haveT Then
rv = rv + 1
haveT = False
End If
End If
Next i
End If
TCount = rv
End Function
Something like this.
You may need to adjust if I made wrong assumptions about your rules.
Function TCount(rng As Range)
Const GAP_SIZE As Long = 5 '<< low number for testing...
Dim rv As Long, i As Long, fCount As Long, n As Long, d
Dim haveT As Boolean, earlyT as Boolean
rv = 0
d = rng.Value
n = UBound(d, 1)
fCount = 0
If n > GAP_SIZE Then
For i = 1 To n
If d(i, 1) = "T" Then
fCount = 0
If i <= GAP_SIZE Then earlyT = True '<<EDIT
haveT = True
Else
fCount = fCount + 1
If fCount = GAP_SIZE And haveT Then
rv = rv + 1
haveT = False
End If
End If
Next i
End If
TCount = rv - IIf(earlyT, 1, 0) '<< EDIT
End Function
In the 'power' sheet under the column D,E & F there were formulas written in the cells; however, after running the following macro (I think), the aforementioned formulas vanished. How did this happen? And how can I retain the original formulas while running the macro?
Sub ReadData()
Dim i, j, k, obs, n As Integer
Dim value, sum As Double
Dim resultsExist As Boolean
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.StatusBar = "Read Data: Copying data"
' Copy factor values
Sheets("Power").Range("IData").Resize(maxObserv).Clear
Sheets("Data").Select
Rows("1:1").Select
i = FindColumn(Sheets("Data"), Range("Name").value)
If i = 0 Then GoTo Cleanup
Cells(1, i).Select
ActiveCell.Range("A2:A" & maxObserv).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Power").Select
Range(ValuePos).PasteSpecial xlPasteValues
Application.CutCopyMode = False
' Copy default data
Sheets("Data").Select
Range("A2:A" & maxObserv).Select
Selection.Copy
Sheets("Power").Select
Range(DefaultPos).Select
ActiveSheet.Paste
Application.CutCopyMode = False
' Copy segment data
Sheets("Data").Select
j = FindColumn(Sheets("Data"), "ID")
If j > 0 Then
ActiveSheet.Range(Cells(1, j), Cells(maxObserv, j + 3)).Select ' Change here to adjust sample size
Selection.Copy
Sheets("Power").Select
Range(InfoPos).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
' Sort data
Application.StatusBar = "Read Data: Sorting"
Sheets("Power").Select
Range("IData").Select
Selection.Sort Key1:=Range(ValuePos), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
obs = 1
value = -9999999
Do Until Cells(obs + 4, 2) = ""
If Cells(obs + 4, 1) <> value Then
If (n > 1) And (sum > 0) Then
For k = obs - n To obs - 1
Cells(k + 4, 2) = sum / n
Next k
End If
n = 1
value = Cells(obs + 4, 1)
sum = Cells(obs + 4, 2)
Else
n = n + 1
sum = sum + Cells(obs + 4, 2)
End If
obs = obs + 1
Loop
' Retrieve or calculate buckets range
Sheets("Analysis").Select
k = FindColumn(Sheets("Results"), Range("Name").value)
If (k > 0) Then resultsExist = (Sheets("Results").Cells(6, k) <> "") Else resultsExist = False
If resultsExist Then
Application.StatusBar = "Read Data: Retrieving stored results"
Range("loBucket") = Sheets("Results").Cells(11, k)
Range("hiBucket") = Sheets("Results").Cells(12, k)
Range("upperCutoff") = 2.95 / Sheets("Results").Cells(7, k) + Sheets("Results").Cells(6, k)
Range("lowerCutoff") = 2 * Sheets("Results").Cells(6, k) - Range("upperCutoff")
Else
Application.StatusBar = "Read Data: Calculating suggestions"
Calculate
Range("loBucket") = Range("minData") ' Alternatively one could set this
Range("hiBucket") = Range("maxData") ' to 5% and 95% percentile
Range("lowerCutoff") = Application.WorksheetFunction.Percentile(Range("Data"), 0.05)
Range("upperCutoff") = Application.WorksheetFunction.Percentile(Range("Data"), 0.95)
End If
Calculate
Cleanup:
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
New edit: sorry I've left out the option explicit part of the code, it's like this -
Option Explicit
Const maxObserv As Integer = 30000
Const ValuePos As String = "A5"
Const DefaultPos As String = "B5"
Const InfoPos As String = "C4"
New edit: FindColumn is a function defined as below -
Function FindColumn(searchSheet As Worksheet, colName As String) As Integer
Dim i As Integer
i = 2
Do While searchSheet.Cells(1, i) <> ""
If searchSheet.Cells(1, i) = colName Then
FindColumn = i
Exit Do
End If
i = i + 1
Loop
End Function
New edit: below are the codes run before the aforementioned codes under sub "ReadData()", which might affect the result -
Sub AdjustModel()
Dim obs As Integer
Dim tmpRange As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' Count number of observations in Data sheet
Sheets("Data").Select
obs = 1
Do Until Cells(1 + obs, 1) = "" And Cells(2 + obs, 1) = ""
obs = obs + 1
Loop
' Adjust names to required length
ActiveWorkbook.Names("Data").RefersTo = "=Power!$A$5:$A$" & (5 + obs) ' factor values
ActiveWorkbook.Names("DData").RefersTo = "=Power!$B$5:$B$" & (5 + obs) ' default flag
ActiveWorkbook.Names("LData").RefersTo = "=Scores!$A$5:$A$" & (5 + obs) ' logit values
ActiveWorkbook.Names("SData").RefersTo = "=Scores!$B$5:$B$" & (5 + obs) ' factor scores
ActiveWorkbook.Names("PData").RefersTo = "=Power!$T$5:$V$" & (5 + obs) ' data for power calculation
ActiveWorkbook.Names("IData").RefersTo = "=Power!$A$5:$F$" & (5 + obs) ' information data
Sheets("Power").Names("BData").RefersTo = "=Power!$G$5:$G$" & (5 + obs) ' bucket number of observation
Sheets("Scores").Names("BData").RefersTo = "=Scores!$C$5:$C$" & (5 + obs) ' bucket number of observation
'Adjust formulas to correct length
Sheets("Power").Range("PData").Formula = Sheets("Power").Range("PData").Rows(1).Formula
Sheets("Power").Range("BData").Formula = Sheets("Power").Range("BData").Cells(1, 1).Formula
Sheets("Scores").Range("BData").Formula = Sheets("Scores").Range("BData").Cells(1, 1).Formula
Sheets("Scores").Range("LData").Formula = Sheets("Scores").Range("LData").Cells(1, 1).Formula
Sheets("Scores").Range("SData").Formula = Sheets("Scores").Range("SData").Cells(1, 1).Formula
' Adjust charts
Sheets("Analysis").ChartObjects("Chart 1").Chart.SeriesCollection(1).XValues = Range("PData").Columns(1)
Sheets("Analysis").ChartObjects("Chart 1").Chart.SeriesCollection(1).Values = Range("PData").Columns(2)
' Cleanup
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
There are a few main points I just want to make about your code that should help.
Avoid using .Select
Always explicitly state the sheet (and workbook, if applicable) when using multiple worksheets. This can cause many headaches if you don't, especially if using .Select and are bouncing around sheets copying/pasting. This may be a reason your PasteSpecial is overwriting data you want - you don't specify the sheet it should paste over.
Use Option Explicit at the top, to force you to declare all variables.
The way you are declaring variables isn't doing what you think it is.
I'll start with Point 4 first. You're doing
Dim i, j, k, obs, n As Integer - I assume you wish to have i, j, k, etc. as Integers. Only n is being declared as an integer...the others are the default (Variant). For each variable, you need to explicitly tell VBA what type you want. So, use Dim i as Integer, j as Integer, k as Integer, etc. In my code, you'll see I'm doing Dim i&, j&, the & is shorthand for As Integer. (See this page for a few more, such as # for As Double)
Point 3 - I'm not sure where the ValuePos variable is set, so that may cause an issue with your pasting. This is where Option Explicit helps you make sure you have the variables you are trying to use.
The first and second points are contained in my code. I tried to leave your code as-is, but comment out lines you don't need, and also added a few comments of my own.
The main concern I have is that I'm not sure what sheets each range you need, so look closely and adjust as necessary.
Option Explicit
Sub ReadData()
Dim i&, j&, k&, obs&, n&
Dim value#, sum#
Dim resultsExist As Boolean
' I think you want these as ranges, but change if not.
Dim maxObserv As Range, ValuePos As Range, findColumn As Range, defaultPos As Range
Dim powerWS As Worksheet, dataWS As Worksheet, analysisWS As Worksheet, resultsWS As Worksheet
Dim infoPos As Range
Set powerWS = Sheets("Power")
Set dataWS = Sheets("Data")
Set analysisWS = Sheets("Analysis")
Set resultsWS = Sheets("Results")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.StatusBar = "Read Data: Copying data"
' Copy factor values
powerWS.Range("IData").Resize(maxObserv).Clear
'Sheets("Data").Select ' You don't need to use `.select`, you can just work directly with the data. Plus, you never do anything with this selection
' Rows("1:1").Select
i = findColumn(dataWS, Range("Name").value)
'If i = 0 Then GoTo Cleanup 'Don't use GoTo, not best practice. Instead just do the following
If i = 0 Then
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
'Cells(1, i).Select
'ActiveCell.Range("A2:A" & maxObserv).Select
'Application.CutCopyMode = False
'Selection.Copy ' This can be replaced with the below, to avoid using .Select
' I don't know which sheet you wanted, so change the `powerWS` to whatever sheet it should be
powerWS.Cells(1, i).Copy
powerWS.Range(ValuePos).PasteSpecial xlPasteValues ' WHERE DOES ValuePos come from???
Application.CutCopyMode = False
' Copy default data
'Sheets("Data").Select
'Range("A2:A" & maxObserv).Select
'Selection.Copy
dataWS.Range("A2:A" & maxObserv).Copy
powerWS.Range(defaultPos).Paste
Application.CutCopyMode = False
' Copy segment data
j = findColumn(dataWS, "ID")
If j > 0 Then
With dataWS
.Range(.Cells(1, j), .Cells(maxObserv, j + 3)).Copy ' Change here to adjust sample size
End With
'Sheets("Power").Select
powerWS.Range(infoPos).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
' Sort data
Application.StatusBar = "Read Data: Sorting"
'Sheets("Power").Select
'Range("IData").Select
powerWS.Range("IData").Sort Key1:=powerWS.Range(ValuePos), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
obs = 1
value = -9999999
Do Until powerWS.Cells(obs + 4, 2) = ""
With powerWS
If .Cells(obs + 4, 1) <> value Then
If (n > 1) And (sum > 0) Then
For k = obs - n To obs - 1
.Cells(k + 4, 2) = sum / n
Next k
End If
n = 1
value = .Cells(obs + 4, 1)
sum = .Cells(obs + 4, 2)
Else
n = n + 1
sum = sum + .Cells(obs + 4, 2)
End If
obs = obs + 1
End With
Loop
' Retrieve or calculate buckets range
'Sheets("Analysis").Selecth
With analysisWS
k = findColumn(resultsWS, resultsWS.Range("Name").value) ' What sheet is "Name" on, I assumed the "Results" sheet
If (k > 0) Then resultsExist = (resultsWS.Cells(6, k) <> "") Else resultsExist = False
If resultsExist Then
Application.StatusBar = "Read Data: Retrieving stored results"
.Range("loBucket") = Sheets("Results").Cells(11, k)
.Range("hiBucket") = Sheets("Results").Cells(12, k)
.Range("upperCutoff") = 2.95 / Sheets("Results").Cells(7, k) + Sheets("Results").Cells(6, k)
.Range("lowerCutoff") = 2 * Sheets("Results").Cells(6, k) - Range("upperCutoff")
Else
Application.StatusBar = "Read Data: Calculating suggestions"
Calculate
.Range("loBucket") = .Range("minData") ' Alternatively one could set this
.Range("hiBucket") = .Range("maxData") ' to 5% and 95% percentile
.Range("lowerCutoff") = Application.WorksheetFunction.Percentile(.Range("Data"), 0.05)
.Range("upperCutoff") = Application.WorksheetFunction.Percentile(.Range("Data"), 0.95)
End If
End With
Calculate
'Cleanup:
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I hope this helps get to the bottom of it. If not, I still recommend trying to break down the removal of .Select and using the explicit sheet names/ranges. But again, if this is the only code you're using, ValuePos is empty, so when you go to paste to that range, there's ...no range? You should add some declaration for that variable.
Edit: As #vacip mentions, you can step through the macro with F8 and watch what each line does. Especially pay attention when you get to the PasteSpecial lines. It'll allow you to see where the pasting is being done, so you can tweak accordingly.
I have the below query (thanks to stackoverflow) that will loop through a list of groups and give me the permissions the group will have for a category. In Linqpad I can export the result into one Excel sheet, but I was wondering if it was possible to export each group result in the loop to a separate sheet in the Excel file. I was going to try in C# first, but I was wondering if it can be done via SQL or Linqpad as well.
Also, Ad Hoc Distributed Queries are disabled on the server.
SELECT GroupId, Name
INTO #GroupTemp
FROM [Group]
DECLARE #Id INT
WHILE EXISTS (
SELECT * FROM #GroupTemp
)
BEGIN
SELECT TOP 1 #Id = GroupId
FROM #Temp
SELECT g.NAME AS 'GroupName'
,c.NAME AS 'CategoryName'
,c.CategoryId
,c.ParentCategoryId
,p.[Read]
,p.Edit
,p.[Delete]
,p.[Add]
,p.Share
,p.Admin
FROM GroupCategoryPermission p
INNER JOIN [Group] g ON p.GroupId = #Id
INNER JOIN Category c ON p.CategoryID = c.CategoryID
WHERE g.GroupId = #Id
DELETE #GroupTemp
WHERE GroupId = #Id
END
I just decided to use an Excel macro after I exported the query from Linqpad. My VBA is a little rusty and I have a couple of small issues that I need to work out (I'm sure there is an easier way than I did it), but this is okay for now. Basically, I searched for every row in column one with GroupName as the value. From there I stored those in an array and used the different in between each for each sheet to be added.
Option Explicit
Private Function Sleep()
Application.Wait Now + 1 / (24 * 60 * 60.0# * 2)
End Function
'Remove 1st row of Sheet 1 and blank rows from sheet
Private Function CheckEmpty()
On Error Resume Next
Worksheets(1).Select()
Columns("A").SpecialCells(xlBlanks).EntireRow.Delete()
Rows("1:1").Select()
Selection.Delete Shift:=xlUp
End Function
'Function to get the name of the group and name the sheet that name
Private Function NameSheet()
Dim groupName As String
groupName = ActiveSheet.Range("A2").Value
If Len(groupName) > 31 Then
groupName = Left(groupName, 31)
ActiveSheet.Name = groupName
Else
ActiveSheet.Name = groupName
End If
End Function
'This will format the sheet
Private Function FormatSheet()
Cells.Select()
With Selection
.WrapText = False
End With
Rows("1:1").Select()
Selection.Font.Bold = True
Cells.Select()
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Columns.AutoFit()
End With
End Function
'Main sub to separate groups into their own sheets
Sub SplitToSheets()
'Variables
Dim ws As Worksheet, rng As Range, cell As Range, findString As String
Dim counter As Long, numbers() As Long, lastRow As Long, firstRow As Long
'Clean sheet 1
Worksheets(1).Activate()
CheckEmpty()
FormatSheet()
'Set the range that we will be checking
firstRow = Rows("1:1").Row
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A" & firstRow & ":" & "A" & lastRow)
rng.Select()
'Set the counter so we loop through array
counter = 1
'Loop through array and store row numbers
For Each cell In rng
If cell.Value = "GroupName" Then
ReDim Preserve numbers(counter)
numbers(counter) = cell.Row
'Increase counter by 1
counter = counter + 1
End If
Next
'Separate groups to sheet using numbers array
'Variables
Dim inx As Long, rStart As Long, rEnd As Long, ind As Long
'Copy first group to new sheet on it's own (need to change logic to avoid separation, eventually)
rStart = numbers(1)
rEnd = numbers(2) - 1
Rows(rStart & ":" & rEnd).Select()
Selection.Copy()
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial(Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False)
NameSheet()
FormatSheet()
'Index Counter for looping through array
ind = 0
For inx = LBound(numbers) To UBound(numbers)
'Need to loop once and make sure the counter is greater than 1
If ind > 0 Then
'Revert to sheet 1
Worksheets(1).Select()
'Start row number
rStart = numbers(ind)
'End row number
rEnd = (numbers(ind) - numbers(ind - 1))
'Selection must start on second group
If rEnd > 1 Then
'Select range
Rows(rStart & ":" & rStart + rEnd).Select()
'Copy
Selection.Copy()
'Add next availble sheet
Sheets.Add After:=Sheets(Sheets.Count)
'Paste values
Selection.PasteSpecial(Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False)
'Set sheet name and rename to match group
NameSheet()
FormatSheet()
Sleep()
End If
End If
'Increase index by 1
ind = ind + 1
Next
'This deletes the main sheet that we no longer need
Application.DisplayAlerts = False
Worksheets(1).Delete()
Application.DisplayAlerts = True
Worksheets(1).Activate()
End Sub
'This macro will give option to seach for sheet
Sub GetSheet()
Dim SearchData As String
SearchData = InputBox("Enter 'exact' group name.")
If SearchData <> vbNullString Then
On Error Resume Next
Sheets(SearchData).Activate()
If Err.Number <> 0 Then MsgBox "Unable to find group named: " & SearchData
On Error GoTo 0
End If
End Sub
I've receieved a report in a rolled up fashion in Excel that I need to flatten out in order to import it into Access. Here's a sample of the row:
What needs to happen is the Customer Account and Name need to be transposed to be adjacent to the Voucher line, and needs to be copied so each voucher line has this information. After the transformation, the data should look like this:
Customer Account | Name | Date | Voucher | Invoice | Transation Text | Currency
Note that the row starting with "USD" denotes the end of records for that customer.
I have successfully implemented the following code:
Sub Process_Transactions()
'turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim i As Long
For i = 1 To 731055
'Move two columns in
ActiveCell.Offset(0, 2).Select
'Select the customer account and name
Range(ActiveCell, ActiveCell.Offset(1, 1)).Select
'Copy and paste it down two rows and over two columns
Selection.Cut
ActiveCell.Offset(2, -2).Select
ActiveSheet.Paste
'Hop up a couple rows and delete 3 rows before the data that are not useful
Rows(ActiveCell.Offset(-2).Row).Select
Selection.Delete Shift:=xlUp
Selection.Delete Shift:=xlUp
Selection.Delete Shift:=xlUp
'Select the next row
Rows(ActiveCell.Offset(1).Row).Select
'If the first record in the row is not "USD", then we have multiple rows for
'this customer
While (ActiveCell.Offset(0, 2) <> "USD")
'Copy and Paste the customer account and number for each
'transaction row
ActiveCell.Select
Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, 1)).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
ActiveCell.Select
ActiveCell.Offset(1, 0).Select
Wend
'Delete the two rows after the data that we need
ActiveCell.Select
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
ActiveCell.Select
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
'Move to the next row to start over
ActiveCell.Select
Debug.Print "Current Row: " & i
Next i
'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
The problem is that the program is very slow. I let the code run for approximately 10 hours last night, and it only processed 33k. I've got roughly 1.5 mil records to process.
I realize that the technique I am using is actually moving the activecell around, so removing that would likely help. However, I am unsure how to proceed. If this is a lost cause and better suited for a .net implementation, feel free to suggest that.
Your code is jam-packed with Excel-VBA methods that are very inefficient! I'll take a few shots:
Don't use .Select and Selection.. That's super slow.
Why do this
Range(ActiveCell, ActiveCell.Offset(1, 1)).Select
Selection.Cut
when you can do this
Range(ActiveCell, ActiveCell.Offset(1, 1)).Cut
Also don't use ActiveCell to move around your sheet. Just do operations directly on whatever cell or row you need, e.g.
Sheet1.Cells(i,2).Copy
Sheet1.Cells(i,1).Paste
Actually, avoid copy/pasting altogether and just say
Sheet1.Cells(i,1).Value = Sheet1.Cells(i,2).Value
Avoid referring to the same object many times and use With instead. Here, Sheet1 is used twice, so you could write this:
With Sheet1
.Cells(i,1).Value = .Cells(i,2).Value
End With
The above are just examples that you will have to adjust to your circumstances, and there is more to optimise, but they'll get you started. Show us your code once you've cleaned it up, and more advice will come!
The fast way to do this would be to grab large chunks of data into a 2-D variant array
Dim varr as Variant
varr=Worksheets("Sheet1").Range("C5:G10005")
then loop on the array and create another variant 2-d array (varr2)second that looks the way you want it, then write the variant array to another worksheet:
Worksheets("Sheet2").Range("A2:G2")=varr2
You don't have to select a cell on every command you execute.
Here is a try:
Dim i As Long
'Suppose you want to start on cell A1
With ActiveSheet
For i = 1 To 731055
'Move two columns to the right and select the customer account and name
'.Range("C" & i & ":D" & i + 1).Cut
'Cut and paste it down two rows and over two columns
'.Range("A" & i + 2 & ":B" & i + 3).Paste
.Range("A" & i + 2 & ":B" & i + 3).Value = .Range("C" & i & ":D" & i + 1).Value
'Hop up a couple rows and delete 3 rows before the data that are not useful
.Range("A" & i & ":C" & i + 2).EntireRow.Delete
'If the first record in the row is not "USD", then we have multiple rows for
'this customer
While (.Range("C" & i + 1).Value <> "USD")
'Copy and Paste the customer account and number for each
'transaction row
'.Range("A" & i & ":B" & i).Copy
'.Range("A" & i + 1 & ":B" & i + 1).Paste
.Range("A" & i + 1 & ":B" & i + 1).Value = .Range("A" & i & ":B" & i).Value
i = i + 1
Wend
'Delete the two rows after the data that we need
.Range("A" & i + 1 & ":A" & i + 2).EntireRow.Delete
'Move to the next row to start over
Debug.Print "Current Row: " & i
Next i
End With
[edit] i changed a little bit my code to copy only the values (this will be much much faster) instead of copy/paste >> see if you really need to copy paste to keep format or so
[edit] Nick: There were a few numbers that were just a little off, so I've updated the answer to reflect these.
I also posted this on Twitter, and got the following from #VisBasApp:
Sub Process_TransactionsPAT()
Const COL_CUSTOMER_ACC As Long = 3
Const COL_CUSTOMER_NAME As Long = 4
Const COL_CUSTOMER_VOUCHER As Long = 4
Const COL_CUSTOMER_INVOICE As Long = 5
Const COL_CUSTOMER_TRANS As Long = 6
Const COL_CUSTOMER_CURR As Long = 7
Const COL_CUSTOMER_AMT_CUR As Long = 8
Const COL_CUSTOMER_BAL_CUR As Long = 9
Const COL_CUSTOMER_BAL As Long = 10
Const COL_CUSTOMER_DUE_DATE As Long = 11
Const COL_CUSTOMER_COL_CODE As Long = 12
Const TEXT_TO_CHECK As String = "Customer account"
Dim accNumber As Variant
Dim accName As String
Dim index As Long
Dim counter As Long
Dim originalData As Variant
Dim transferedData() As Variant
'turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
originalData = Range("A1:L720909")
counter = 0
For i = 1 To UBound(originalData, 1)
If originalData(i, COL_CUSTOMER_ACC) = TEXT_TO_CHECK Then
' go to the first row under the text 'Customer Account'
index = i + 1
' get name and account number
accNumber = originalData(index, COL_CUSTOMER_ACC)
accName = originalData(index, COL_CUSTOMER_NAME)
' go to the first row under the text 'Date'
index = index + 2
counter = counter + 1
While (UCase(originalData(index, COL_CUSTOMER_ACC)) <> "USD")
ReDim Preserve transferedData(1 To 12, 1 To counter)
transferedData(1, counter) = accNumber
transferedData(2, counter) = accName
transferedData(3, counter) = originalData(index, COL_CUSTOMER_ACC)
transferedData(4, counter) = originalData(index, COL_CUSTOMER_VOUCHER)
transferedData(5, counter) = originalData(index, COL_CUSTOMER_INVOICE)
transferedData(6, counter) = originalData(index, COL_CUSTOMER_TRANS)
transferedData(7, counter) = originalData(index, COL_CUSTOMER_CURR)
transferedData(8, counter) = originalData(index, COL_CUSTOMER_AMT_CUR)
transferedData(9, counter) = originalData(index, COL_CUSTOMER_BAL_CUR)
transferedData(10, counter) = originalData(index, COL_CUSTOMER_BAL)
transferedData(11, counter) = originalData(index, COL_CUSTOMER_DUE_DATE)
transferedData(12, counter) = originalData(index, COL_CUSTOMER_COL_CODE)
index = index + 1
counter = counter + 1
Wend
' it is not the best technique but for now it works
i = index + 1
counter = counter - 1
End If
Next i
' add data on a new sheet
Sheets.Add
Cells(1, 1) = "Customer Account"
Cells(1, 2) = "Name"
Cells(1, 3) = "Date"
Cells(1, 4) = "Voucher"
Cells(1, 5) = "Invoice"
Cells(1, 6) = "Transaction Left"
Cells(1, 7) = "Currency"
Cells(1, 8) = "Amount in currency"
Cells(1, 9) = "Balance in currency"
Cells(1, 10) = "Balance"
Cells(1, 11) = "Due Date"
Cells(1, 12) = "Collection letter code"
For i = 1 To UBound(transferedData, 2)
For j = 1 To UBound(transferedData, 1)
Cells(i + 1, j) = transferedData(j, i)
Next j
Next i
Columns.AutoFit
'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
This takes roughly 2 minutes to parse 750,000 records.
I would throw the data as-is on a database, and write a query to do that. I'll write a query and update the answer when I get home (I'm on my phone, its impossible to write SQL :)