I am trying define two ranges (myADR & myOCC) to use in a Linest Formula. However I keep getting this 1004 error. I've tried two ways, the second way is commented out. Does anyone know how to fix this?
Sub LinestFormula()
Dim nCols As Integer
Dim myOCC As Range
Dim myADR As Range
Dim nRows3 As Integer
Range("A1").CurrentRegion.Select
nCols = Selection.Columns.Count
ActiveCell.Offset(5, 1).Resize(1, nCols - 2).Select
Selection.Copy
Range("A1").Select
Selection.End(xlToRight).Offset(0, 2).Select
ActiveCell = "OCC"
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues, Transpose:=True
nRows3 = Selection.Rows.Count
'Selection = myOCC
Cells(5, 2).Select
Selection.Resize(1, nCols - 2).Select
Selection.Copy
Range("A1").Select
Selection.End(xlToRight).Offset(0, 3).Select
ActiveCell = "ADR"
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues, Transpose:=True
Range("A1").End(xlToRight).Offset(1, 2).Resize(nRows3, 1).Select
Selection = myOCC
Range("A1").End(xlToRight).Offset(1, 3).Resize(nRows3, 1).Select
Selection = myADR
rather then:
Selection = myOCC
use:
Set myOCC = Selection
etc.
Related
I am using the following code to extract a list of unique customers, I would like to extract a list based on a combination of two columns, column F and column K. Is there a way to update this code, that would be effective?
Sub FilterUniqueCustomer()
Application.ScreenUpdating = False
'Advance Filter
Range("F1").Select
Application.CutCopyMode = False
Application.CutCopyMode = False
Range("F1:F100").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"S1"), Unique:=True
ActiveWindow.SmallScroll Down:=-6
'Copy Values
Range("T2:T100").Select
Selection.copy
Range("U2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Clear Formatting
Range("N4").Select
Selection.copy
Columns("S:S").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False 'Clears clipboard
Call DeleteZerosCustomer
Application.ScreenUpdating = True
End Sub
Like this using a dictionary to get unique combinations and array to work faster than in sheet.
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim arr(), i As Long, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet3") '<==Change as required
arr = .Range("F1:K6").Value
For i = LBound(arr, 1) To UBound(arr, 1)
dict(arr(i, 1) & "," & arr(i, 6)) = 1
Next
End With
Dim key As Variant, rowCounter As Long
For Each key In dict.keys
rowCounter = rowCounter + 1
Worksheets("Sheet2").Cells(rowCounter + 1, 1).Resize(1, 2) = Split(key, ",") '<== Change output sheet as required
Next
Application.ScreenUpdating = True
End Sub
I'm recording a macro and need some help. I'd like copy and paste the values from the column G of the "SalesData" worksheet into cells A2, A12, A22 etc of the "Results" worksheet until there's no more values in the column G.
VBA is pretty new to me, I've tried using Do/Until, but everything crashed. Could you please help me? Please see the code I've recorded below. Thank you!
Sub(x)
Sheets("SalesData").Select
Range("G2").Select
Selection.Copy
Sheets("Results").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A12").Select
Sheets("SalesData").Select
Range("G3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A22").Select
Sheets("SalesData").Select
Range("G4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A32").Select
Sheets("SalesData").Select
Range("G5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I prefer to find the last cell in the column first then use a For loop.
Since you are only doing the values we can avoid the clipboard and assign the values directly.
Since you paste is every 10 cells we can use a separate counter to move down 10 each loop.
Sub x()
Dim ws As Worksheet
Dim lst As Long
Dim i As Long, j As Long
'use variable to limit the number of times we type the same thing
Set ws = Worksheets("Results")
'First row of the output
j = 2
'using with and the "." in front of those items that belong to it also limits the typing.
With Worksheets("SalesData")
'Find the last row with values in Column G
lst = .Cells(.Rows.Count, 7).End(xlUp).Row
'Loop from the second row to the last row.
For i = 2 To lst
'Assign the value
ws.Cells(j, 1).Value = .Cells(i, 7).Value
'Move down 10 rows on the output
j = j + 10
Next i
End With
End Sub
here is the same thing but using range variables
Sub x()
Dim src As Range
Dim dst As Range
Set dst = Worksheets("Results").Range("a2") ' point to top cell of destination
With Worksheets("SalesData")
For Each src In Range(.Cells(2, "g"), .Cells(.Rows.Count, "g").End(xlUp)) ' loop through used cell range in column G
dst.Value = src.Value
Set dst = dst.Offset(10) ' move destination pointer down 10 rows
Next src
End With
End Sub
This is just for fun/practice for another way to do it:
Sub copyFromG()
Dim copyRng As Range, cel As Range
Dim salesWS As Worksheet, resultsWS As Worksheet
Set salesWS = Sheets("SalesData")
Set resultsWS = Sheets("Results")
Set copyRng = salesWS.Range("G2:G" & salesWS.Range("G2").End(xlDown).Row) ' assuming you have a header in G1
For Each cel In copyRng
resultsWS.Range("A" & 2 + 10 * copyRng.Rows(cel.Row).Row - 30).Value = cel.Value
Next cel
End Sub
I have a module on VBA which basically runs a foreach loop for every cell that contains text in a column. The contents of each cell are then copied to another sheet where another function is called upon (DailyGet). The contents generated from the function are the copied back into the original sheet (i generated the code for this by recordings a macros). However, since there are many cells to process in the foreach loop, it is quite time consuming because the macros switches between sheets each time to run. Is there any way to speed up the process?
Sub DailyComposite()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("B2:B100")
For Each cel In SrchRng
If cel.Value <> "" Then
Worksheets("Calculations").Range("B1").Value = cel.Value
Sheets("Calculations").Select
Call DailyGet
Range("D3:Z3").Select
Application.CutCopyMode = False
Selection.copy
Sheets("Summary").Select
cel.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End If
Next cel
Sheets("Calculations").Select
Application.CutCopyMode = False
Range("A1").Select
Sheets("Summary").Select
Range("A1").Select
End Sub
For starters, you can get rid of all the selecting
Range("D3:Z3").Select
Application.CutCopyMode = False
Selection.copy
Sheets("Summary").Select
cel.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Should be:
Sheets("Calculations").Range("D3:Z3").Copy
cel.Offset(0, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Second, why must you switch to the Calculations sheet before running DailyGet. If the function dailyGet uses ActiveSheet, change it to Sheets("Calculations"). If you do that, you never need to switch sheets.
Third, turn off ScreenUpdating when you start the macro, and turn it back on when done:
Application.ScreenUpdating = False
In general you should always avoid select. Instead try and declare/instantiate your variables as shown. I've commented the code below to explain what is going on. Let me know if you have any questions.
Option Explicit 'Always use this it helps prevent simple errors like misspelling a variable
Sub DailyComposite()
'Declare all variables you are going to use
Dim wb As Workbook 'The workbook youa re working with
Dim wsCalc As Worksheet 'Calculations sheet
Dim wsSum As Worksheet 'Summary Sheet
Dim SrchRng As Range, cel As Range
'Instantiate your variables
Set wb = ThisWorkbook
Set wsCalc = wb.Worksheets("Calculations") 'now you can simply use the variable to refer to the sheet NO SELECTING
Set wsSum = wb.Worksheets("Summary") 'SAME AS ABOVE
Set SrchRng = Range("B2:B100")
Application.ScreenUpdating = False 'Turn this off to speed up your macro
For Each cel In SrchRng
If cel.Value <> "" Then
'This ... Worksheets("Calculations").Range("B1").Value = cel.Value becomes...
wsCalc.Range("B1").Value = cel.Value
'Sheets("Calculations").Select ... this line can be deleted
Call DailyGet
'Range("D3:Z3").Select
'Application.CutCopyMode = False
'Selection.Copy
'Sheets("Summary").Select
'cel.Offset(0, 1).Select
'Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
' xlNone, SkipBlanks:=False, Transpose:=False
'All of the above can be replaced by...
wsCalc.Range("D3:Z3").Copy
cel.Offset(0, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next cel
'You can keep these if you truly want to select the A1 cell at the end
'Sheets("Calculations").Select
wsCalc.Activate
Range("A1").Select
'Sheets("Summary").Select
wsSum.Activate
Range("A1").Select
Application.ScreenUpdating = True 'Turn it back on
End Sub
There is no need to copy and paste values. I select Worksheets("Calculations") to insure that DailyGet will run as before.
Sub DailyComposite()
Dim SrchRng As Range, cel As Range
Set SrchRng = Worksheets("Summary").Range("B2:B100")
With Worksheets("Calculations")
.Select
For Each cel In SrchRng
If cel.Value <> "" Then
Range("B1").Value = cel.Value
Call DailyGet
cel.Offset(0, 1).Resize(, 23).Value = Range("D3:Z3").Value
End If
Next cel
End With
End Sub
I try to copy in the excel few rows to a table, and give the same auto number to the rowa I add in each opparation.
I have a macro that copy the rows and gives the first line (of the new lines I just added) the next auto number. I want to add the same number to the other rows. (and each time there can be different numbers of rows, but not more then 16).
my macro is:
Sub copy_order()
'
'
Sheets("orders").Select
Application.Goto Reference:="product"
ActiveCell.Range("A1:D16").Select
Selection.Copy
Application.Goto Reference:="orders_table"
Selection.End(xlDown).Select
ActiveCell.Offset(1, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, -1).Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R[-1]C+1"
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Goto Reference:="product"
ActiveCell.Offset(0, 0).Range("A1:C1").Select
Selection.ClearContents
Application.Goto Reference:="orders_table"
End Sub
thank you, Keren.
Not sure I followed all your offsets correctly, but this should get you close...
Sub copy_order()
Dim rngDest As Range, rngCopy As Range, sht As Worksheet, num
Dim c As Range
Set sht = Sheets("orders")
Set rngCopy = sht.Range("product").Range("A1:D16")
Set rngDest = sht.Range("orders_table").Cells(1).End(xlDown).Offset(1, 0)
rngDest.Resize(rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value
num = rngDest.Offset(-1, -1).Value + 1
Do While Application.CountA(rngDest.Resize(1, rngCopy.Columns.Count)) > 0
rngDest.Offset(0, -1).Value = num
Set rngDest = rngDest.Offset(1, 0)
Loop
End Sub
I wrote a code to grab the raw data in a file and summarize the data based to "date" of report and copy this summarized data into the target workbook according to the "date" value.
When I tried to run this code. it works fine for one file, but hangs up in another file. When I try to debug it I am not able to follow the flow of code. It breaks up suddenly. Can you help me in fixing this issue?
Option Explicit
Sub file_select()
Dim RequiredFileName As Variant, i As Integer
Dim targetWorkbook As Workbook
' making weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
'RequiredFileName = "c:\myfiles\test.xls"
On Error GoTo EndNow
RequiredFileName = Application.GetOpenFilename(FileFilter:="ALL Files (*.*), *.*", Title:="Get File", MultiSelect:=True)
For i = 1 To UBound(RequiredFileName)
MsgBox RequiredFileName(i), , GetFileName(CStr(RequiredFileName(i)))
Next i
For i = 1 To UBound(RequiredFileName)
Call ProcessOpenFile(RequiredFileName(i), targetWorkbook)
Next i
EndNow: End Sub
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Sub ProcessOpenFile(RequiredFileName, targetWorkbook As Workbook)
Dim RequiredWorkbook As Workbook
'Dim targetWorkbook As Workbook
' get the required workbook
Set RequiredWorkbook = Application.Workbooks.Open(RequiredFileName)
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets("Summary_NV")
Dim RequiredSheet As Worksheet
Set RequiredSheet = RequiredWorkbook.Sheets(1) 'here assumed that source workbook consists only of one sheet i.e., is the required sheet.
RequiredWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
RequiredWorkbook.Sheets(Sheets.Count).Select
RequiredWorkbook.Sheets(Sheets.Count).Name = "SUMMARY" & Sheets.Count
Call Sort_Before(RequiredWorkbook) 'sorting the required file data according to date.
If RequiredSheet.Name = "EVDO_SC_Summary" Then
Call ProcessEVDO(RequiredSheet) 'get the summary of report
Call Sort_After(RequiredWorkbook) ' sort the summary according to date
Call DateChange(RequiredWorkbook) 'changing date format
ElseIf RequiredSheet.Name = "CDMAVoice_SC_Summary" Then
Call ProcessVoice(RequiredSheet)
Call Sort_After(RequiredWorkbook)
Call DateChange(RequiredWorkbook)
ElseIf RequiredSheet.Name = "CDMAData_SC_Summary" Then
Call ProcessData(RequiredSheet)
Call Sort_After(RequiredWorkbook)
Call DateChange(RequiredWorkbook)
End If
Dim iRow As Integer
Dim LastRow_Req As Integer
Dim LastRow_Tar As Integer
Dim LastCol_Req As Integer
LastRow_Req = RequiredWorkbook.Sheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp).Row 'last row summary data
LastCol_Req = RequiredWorkbook.Sheets(Sheets.Count).Cells(1, Columns.Count).End(xlToLeft).Column 'last column of summary data
LastRow_Tar = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row 'last row of target sheet used
RequiredWorkbook.Sheets(Sheets.Count).Range("B1").Resize(LastRow_Req, LastCol_Req - 1).Select 'selecting summary data for copying
Selection.Copy
If targetSheet.Cells(LastRow_Tar, 1).Value < RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then 'if date entered in target sheet last cell is less
If RequiredWorkbook.Sheets(1).Name = "EVDO_SC_Summary" Then 'then the summary report date
targetSheet.Activate
Cells(LastRow_Tar + 1, 16).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(LastRow_Tar + 1, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, LastRow_Tar + 1, 1)
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAVoice_SC_Summary" Then
targetSheet.Activate
Cells(LastRow_Tar + 1, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(LastRow_Tar + 1, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, LastRow_Tar + 1, 1)
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAData_SC_Summary" Then
targetSheet.Activate
Cells(LastRow_Tar + 1, 9).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(LastRow_Tar + 1, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, LastRow_Tar + 1, 1)
End If
End If
For iRow = targetSheet.Range("A12").Row To LastRow_Tar
RequiredWorkbook.Activate
If targetSheet.Cells(iRow, 1).Value < RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then
GoTo A
ElseIf targetSheet.Cells(iRow, 1).Value = RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then
If RequiredWorkbook.Sheets(1).Name = "EVDO_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 16).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAVoice_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAData_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 9).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
End If
ElseIf targetSheet.Cells(iRow, 1).Value > RequiredWorkbook.Sheets(Sheets.Count).Range("A1").Value Then
If RequiredWorkbook.Sheets(1).Name = "EVDO_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 16).Select
Selection.Insert Shift:=xlDown
Exit For
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAVoice_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 2).Select
Selection.Insert Shift:=xlDown
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
ElseIf RequiredWorkbook.Sheets(1).Name = "CDMAData_SC_Summary" Then
targetSheet.Activate
Cells(iRow, 9).Select
Selection.Insert Shift:=xlDown
Cells(iRow, 1).Select
Call Date_update(RequiredWorkbook, targetWorkbook, iRow, 1)
Exit For
End If
End If
A: Next
RequiredWorkbook.Close savechanges:=False
End Sub
Answered in a comment "Code is going into infinite loop" – user1806794