So I'm pretty new to vba, and have only been learning it for about a month for work. I keep having this problem where I get the Error 1004 "Application defined, or object defined error" when I try to run my macro. What I'm trying to do is to go through a list of data, and find out if a row has a specific code attached to it. If it does I want to move a date on that row to a new sheet.
Sub k0Pop()
Dim source As Long
Dim servR As Integer
Dim servC As Integer
Dim patID As Integer
Dim spot1 As Integer
Dim spot2 As Integer
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set sht1 = Sheets("Sheet2")
Set sht2 = Sheets("Sheet4")
servR = 3
For source = 3 To 100000
servC = 2
While sht2.Cells(source, 2) < sht2.Cells(patID, 15)
source = source + 1
Wend
While Cells(source, 2) = Cells((source + 1), 2)
If Cells(source, 6) = "K045A" Then
spot = source
End If
source = source + 1
Wend
If Cells(source, 6) = "K045A" Then
spot = source
source = source + 1
End If
spot2 = source
source = spot1
While (Cells(spot, 5) - Cells(source, 5)) < 365
source = source - 1
Wend
While source < spot
sht1.Cells(servR, servC) = sht2.Cells(source, 5)
source = source + 1
servC = servC + 1
Wend
sht1.Cells(servR, 14) = sht2.Cells(spot, 5)
source = spot2
servR = servR + 1
patID = patID + 1
Next
End Sub
Looks like patID is 0, which is an invalid column. Use F8 to single cycle. Hover over a variable to see its value. Use debug.print's to show intermediate data.
Related
I solved it on my own. I added a for loop. Here is my working code. Thanks to everyone else for trying to help.
Sub runMatch()
Dim critRemID, listRemID, critRemIDstart, listRemIDstart As Range
Set critRemID = Worksheets("Enterprise - score").Cells(2, 1)
Set listRemID = Worksheets("Sheet1").Cells(2, 1)
Set critRemIDstart = Worksheets("Enterprise - score").Cells(2, 30)
Set listRemIDstart = Worksheets("Sheet1").Cells(2, 2)
Dim i, j, index As Integer
i = 0
j = 0
Do While critRemID.Offset(i, 0) <> ""
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
For index = 0 To 84
critRemIDstart.Offset(i, index) = listRemIDstart.Offset(j, index).Value
Next index
i = i + 1
j = 0
index = 0
Else
If listRemID.Offset(j, 0) = "" Then
j = 0
i = i + 1
Else
j = j + 1
End If
End If
Loop
End Sub
I have two sheets, they each have a the same IDs on each sheet but
different sets of data.
I want to scan through the rows of data and if there is a match, copy
the entire row from a certain column to another certain column to the
end of one of the sheets.
Sheet 1 is the sheet I want to copy info into, on the end I've created
the same headers for the data I want to bring over from sheet 2.
the code below is what I have, I set a range up for the IDs and one
for where I want the copied cells to start
Dim critRemID, listRemID, critRemIDstart, listRemIDstart As Range
Set critRemID = Worksheets("Enterprise - score").Cells(2, 1)
Set listRemID = Worksheets("Sheet1").Cells(2, 1)
Set critRemIDstart = Worksheets("Enterprise - score").Cells(2, 30)
Set listRemIDstart = Worksheets("Sheet1").Cells(2, 90)
Dim i, j As Integer
i = 0
j = 0
Do While critRemID.Offset(i, 0) <> ""
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Row(i) = listRemIDstart.Row(j).Value
i = i + 1
j = 0
Else
j = j + 1
End If
Loop
I keep getting this error
Wrong number of arguments or invalid property assignment
I tried going a different route but kept getting confused as shown
below. I was trying to have it copy each cell one by one and once it
reached an empty cell, it would move onto the next ID on the main
sheet and start over but this does nothing, I think it keeps
increasing both IDs on the sheet and never finds a match.
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Offset(i, k) = listRemIDstart.Offset(j, l).Value
k = k + 1
l = l + 1
Else
If listRemIDstart.Offset(j, l) = "" Then
j = j + 1
l = 0
i = i + 1
k = 0
Else
j = j + 1
i = i + 1
l = 0
k = 0
End If
End if
any help is appreciated. Thanks.
Range.Find method could find the key easily.
Dim critRem, listRem As Worksheet
Set critRem = Worksheets("Enterprise - score")
Set listRem = Worksheets("Sheet1")
Dim critRemID, listRemID, cell, matchedCell As Range
With critRem
Set critRemID = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With listRem
Set listRemID = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each cell In critRemID
Set matchedCell = listRemID.Find(cell.Value)
If matchedCell Is Nothing Then 'ID is not found
'Do nothing
Else 'ID is found, matchedCell is pointed to column A now
cell.Offset(0, 29).Resize(1, 10) = matchedCell.Offset(0, 89).Resize(1, 10)
'offset(0,29) means offsetting right 29 columns
'resize(0,10) means resizing the range with 1 row and 10 columns width
'feel free to change the number for your data
End If
Next cell
Note: If you are confused about offset().resize(), there is another approach. cell.Row gives you the row that the data should be written into, and matchedCell.Row gives you the row that the ID matched. So you can access certain cell by something like listRem.Range("D" & matchedCell.Row)
Tried to do it using the loop.
Sub Anser()
Dim critRemID As Range
Dim listRemID As Range
Dim critRemIDstart As Range
Dim listRemIDstart As Range
'::::Change Sheet names and column numbers:::::
Set critRemID = Worksheets("Sheet1").Cells(2, 1)
Set listRemID = Worksheets("Sheet2").Cells(2, 1)
Set critRemIDstart = Worksheets("Sheet1").Cells(2, 2)
Set listRemIDstart = Worksheets("Sheet2").Cells(2, 2)
Dim i, j As Integer
i = 0
j = 0
Do
If critRemID.Offset(i, 0) = listRemID.Offset(j, 0) Then
critRemIDstart.Offset(i) = listRemIDstart.Offset(j)
i = i + 1
j = 0
Else
j = j + 1
End If
Loop While critRemID.Offset(i, 0) <> ""
End Sub
If as you say both sheets have the same IDs, then why not use a Vlookup function to bring the data into Sheet1, then simply copy the results and paste as values so you get rid of the formula on them cells?
Something like a loop running:
For i = 1 to LastRow
Sheet1.cells(i, YourColumnNumber).value = "=VLOOKUP(RC[-1], Sheet2!R1:R1048576, 3, False)"
Next i
I am working on a UserForm that is linked to an Excel Workbook located on a network path. Within the notebook I have a table named Source. This table contains an ID and Source Name. Within the UserForm there is a button to add a new source to the table. My current VBA is as follows:
Private Sub bFinishAdd_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim lr As Long
Set wb = Workbooks.Open("\\datapath\datasub1\datasub2\filename.xlsx")
Set ws = wb.Worksheets("Source")
Set rng = ws.Range("Source[Source]")
If tbNewSourceName <> "" Then
If Application.WorksheetFunction.CountIf(rng, tbNewSourceName) > 0 Then
MsgBox "Source System already exists!"
lbSourceSystems.Enabled = True
bAddSource.Enabled = True
frameAddSource.Enabled = False
lblNewSourceName.Enabled = False
bFinishAdd.Enabled = False
bCancelAdd.Enabled = False
tbNewSourceName = ""
tbNewSourceName.Enabled = False
tbNewSourceName.BorderStyle = fmBorderStyleNone
Exit Sub
Else
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(lr + 1, 1) = lr - 1 + 1000
ws.Cells(lr + 1, 2) = tbNewSourceName
End If
End If
End Sub
Adding a new source triggers the error "Method of '_Default' if object 'range' failed". Excel simply crashes and I cannot debug, but I know the error is caused by:
ws.Cells(lr + 1, 1) = lr - 1 + 1000
ws.Cells(lr + 1, 2) = tbNewSourceName
However, I don't understand why I'm receiving the error or how to fix it. Any ideas?
Obviously using the default method is going wrong somewhere. You can't assign a textbox to a cell. So be explicit. Try:
ws.Cells(lr + 1, 1).Value = lr - 1 + 1000
ws.Cells(lr + 1, 2).Value = tbNewSourceName.Text
I discovered that the same table I was attempting to add to is listed as the RowSource for a ListBox on my UserForm. I updated the code to remove the RowSource prior to adding and adding it back after.
lbSourceSystems.RowSource = ""
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(lr + 1, 1).Value = lr - 1 + 1000
ws.Cells(lr + 1, 2).Value = tbNewSourceName.Text
lbSourceSystems.RowSource = ("'filename.xlsx'!SourceSystems")
I'm new to Excel VBA and this is my first macro, so please forgive me if I've made a very obvious mistake. I have the following code to compare to worksheets and, if a match is found, to make a note on one of the sheets. It runs with no errors, but the changes are not being made. I can't see where I've gone wrong. Thanks in advance for the help.
Sub invalid()
Dim i As Integer
Dim j As Integer
Dim main As Worksheet
Dim invalid As Worksheet
i = 2
Set main = ThisWorkbook.Worksheets(1)
Set invalid = ThisWorkbook.Worksheets(2)
Do
j = 2
Do
If LCase$(invalid.Cells(i, 1).Value) = LCase$(main.Cells(j, 13).Value) Then
main.Cells(j, 14).Value = "Invalid Email"
End If
j = j + 1
Loop While main.Cells(j, 2) = Not Null
i = i + 1
Loop While invalid.Cells(i, 2) = Not Null
End Sub
Try this, it removes one of the loops:
Sub invalid()
Dim i As Long
Dim j As Long
Dim lRow As Long
Dim main As Worksheet
Dim invalid As Worksheet
Set main = ThisWorkbook.Worksheets(1)
Set invalid = ThisWorkbook.Worksheets(2)
lRow = main.Cells(main.Rows.Count, 13).End(xlUp).Row
For i = 2 To lRow
j = 0
On Error Resume Next
j = Application.WorksheetFunction.Match(main.Cells(i, 13), invalid.Range("A:A"), 0)
On Error GoTo 0
If j > 0 Then main.Cells(i, 14) = "Invalid Email"
Next i
End Sub
I was sent an Excel sheet that with 4 charts. The data for the charts is in another workbook that was not provided.
Goal: I want to extract the data from the charts using a VBA sub.
Problem: I am having some trouble with "type mismatch." When I try to assign the Variant array oSeries.XValues to a Range of cells.
Option Explicit
Option Base 1
' 1. Enter the following macro code in a module sheet.
' 2. Select the chart from which you want to extract the underlying data values.
' 3. Run the GetChartValues Sub. The data from the chart is placed in a new worksheet named "ChartName Data".
'
Sub GetChartValues()
'
Dim lxNumberOfRows As Long
Dim lyNumberOfRows As Long
Dim oSeries As Series
Dim lCounter As Long
Dim oWorksheet As Worksheet
Dim oChart As Chart
Dim xValues() As Variant
Dim yValues() As Variant
Dim xDestination As Range
Dim yDestination As Range
Set oChart = ActiveChart
' If a chart is not active, just exit
If oChart Is Nothing Then
Exit Sub
End If
' Create the worksheet for storing data
Set oWorksheet = ActiveWorkbook.Worksheets.Add
oWorksheet.Name = oChart.Name & " Data"
' Loop through all series in the chart and write there values to
' the worksheet.
lCounter = 1
For Each oSeries In oChart.SeriesCollection
xValues = oSeries.xValues
yValues = oSeries.values
' Calculate the number of rows of data. 1048576 is maximum number of rows in excel.
lxNumberOfRows = WorksheetFunction.Min(UBound(oSeries.xValues), 1048576 - 1)
lyNumberOfRows = WorksheetFunction.Min(UBound(oSeries.values), 1048576 - 1)
' Sometimes the Array is to big, so chop off the end
ReDim Preserve xValues(lxNumberOfRows)
ReDim Preserve yValues(lyNumberOfRows)
With oWorksheet
' Put the name of the series at the top of each column
.Cells(1, 2 * lCounter - 1) = oSeries.Name
.Cells(1, 2 * lCounter) = oSeries.Name
Set xDestination = .Range(.Cells(1, 2 * lCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lCounter - 1))
Set yDestination = .Range(.Cells(1, 2 * lCounter), .Cells(lxNumberOfRows + 1, 2 * lCounter))
'Assign the x and y data from the chart to a range in the worksheet
xDestination.value = Application.Transpose(xValues)
yDestination.value = Application.Transpose(yValues)
' This does not work either
' .Range(.Cells(2, 2 * lCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lCounter - 1)).value = Application.Transpose(oSeries.xValues)
' .Range(.Cells(2, 2 * lCounter), .Cells(lxNumberOfRows + 1, 2 * lCounter)).value = Application.Transpose(oSeries.values)
End With
lCounter = lCounter + 1
Next
' Cleanup
Set oChart = Nothing
Set oWorksheet = Nothing
End Sub
The main issue is the following lines:
.Range(.Cells(2, 2 * lCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lCounter - 1)) = Application.Transpose(oSeries.xValues)
.Range(.Cells(2, 2 * lCounter), .Cells(lxNumberOfRows + 1, 2 * lCounter)) = Application.Transpose(oSeries.values)
Upon further inspection using the Locals window, I find the following:
The below code works while the above code does not.
Sub Test2()
Dim A(6) As Variant
'A(1) = 1
A(2) = 2#
A(3) = 3#
A(4) = 4#
A(5) = 5#
Range(Cells(1, 1), Cells(6, 1)).value = Application.Transpose(A)
End Sub
Why doesn't the first piece of code work?
Looping over many cells is slow in this case (I've tried). Please, don't use a loop unless it is seconds for 1,000,000 element.
The main cause is the built-in Transpose function. Transpose can only handle arrays with 2^16 or less elements.
The code below works well. It handles the problem of Transpose function limitation of 2^16 elements. It uses a for loop but the for loop is fast for arrays. For four series and each having 1048576 elements, the Sub took about 10 seconds to run. This is acceptable.
Option Explicit
Option Base 1
' 1. Enter the following macro code in a module sheet.
' 2. Select the chart from which you want to extract the underlying data values.
' 3. Run the GetChartValues Sub. The data from the chart is placed in a new worksheet named "ChartName Data".
'
Public Sub GetChartValues()
Dim lxNumberOfRows As Long
Dim lyNumberOfRows As Long
Dim oSeries As Series
Dim lSeriesCounter As Long
Dim oWorksheet As Worksheet
Dim oChart As Chart
Dim xValues() As Variant
Dim yValues() As Variant
Dim xDestination As Range
Dim yDestination As Range
Set oChart = ActiveChart
' If a chart is not active, just exit
If oChart Is Nothing Then
Exit Sub
End If
' Create the worksheet for storing data
Set oWorksheet = ActiveWorkbook.Worksheets.Add
oWorksheet.Name = oChart.Name & " Data"
' Loop through all series in the chart and write their values to the worksheet.
lSeriesCounter = 1
For Each oSeries In oChart.SeriesCollection
' Get the x and y values
xValues = oSeries.xValues
yValues = oSeries.values
' Calculate the number of rows of data.
lxNumberOfRows = UBound(xValues)
lyNumberOfRows = UBound(yValues)
' 1048576 is maximum number of rows in excel. Sometimes the Array is too big. Chop off the end.
If lxNumberOfRows >= 1048576 Then
lxNumberOfRows = 1048576 - 1
ReDim Preserve xValues(lxNumberOfRows)
End If
If lyNumberOfRows >= 1048576 Then
lyNumberOfRows = 1048576 - 1
ReDim Preserve yValues(lyNumberOfRows)
End If
With oWorksheet
' Put the name of the series at the top of each column
.Cells(1, 2 * lSeriesCounter - 1) = oSeries.Name & " X Values"
.Cells(1, 2 * lSeriesCounter) = oSeries.Name & " Y Values"
Set xDestination = .Range(.Cells(2, 2 * lSeriesCounter - 1), .Cells(lxNumberOfRows + 1, 2 * lSeriesCounter - 1))
Set yDestination = .Range(.Cells(2, 2 * lSeriesCounter), .Cells(lxNumberOfRows + 1, 2 * lSeriesCounter))
End With
' Arrays larger than 2^16 will fail with Transpose function. Therefore must manually transpose
If lxNumberOfRows > 2& ^ 16 Then
'Assign the x and y data from the chart to a range in the worksheet. Use the ManualTranspose for 2^16 or more elements.
xDestination.value = ManualTranspose(xValues)
yDestination.value = ManualTranspose(yValues)
Else
'Assign the x and y data from the chart to a range in the worksheet. Use the built-in Transpose for less than 2^16 elements.
xDestination.value = WorksheetFunction.Transpose(xValues)
yDestination.value = WorksheetFunction.Transpose(yValues)
End If
lSeriesCounter = lSeriesCounter + 1
Next
' Cleanup
Set oChart = Nothing
Set oWorksheet = Nothing
End Sub
' Helper function for when built-in Transpose function cannot be used. Arrays larger than 2^16 must be transposed manually.
Private Function ManualTranspose(ByRef arr As Variant) As Variant
Dim arrLength As Long
Dim i As Long
Dim TransposedArray() As Variant
arrLength = UBound(arr)
ReDim TransposedArray(arrLength, 1)
For i = 1 To arrLength
TransposedArray(i, 1) = arr(i)
Next i
ManualTranspose = TransposedArray
End Function
I have been developing an Excel macro for my company that opens several workbooks, parses them for a specific line of information, stores that line, then once it has gone through each workbook sets the value of a horizontal selection of cells in a single workbook on one of two pages. The issue I am having is upon trying to select the second page I need to put data on to i get a runtime error 1004.
Here is the code;
Sub sortandinsert(listie As Variant)
'Takes in the data array and sorts it as it inserts it into the spreadsheet.
'Expects a 2 dimensional array.
Dim serialarray() As Variant
Dim listlen1 As Integer
Dim listlen2 As Integer
Dim listlen3 As Integer
Dim count1 As Integer
Dim count2 As Integer
Dim SSCcurrentrow As Integer
Dim DSCcurrentrow As Integer
Dim Colstart As Integer
Dim SSCcounter As Integer
Dim DSCcounter As Integer
Dim actbook As Workbook
Dim selectrange As range
Set actbook = ActiveWorkbook
SSCcounter = 0
DSCcounter = 0
Colstart = 1
SSCcurrentrow = 10
DSCcurrentrow = 10
serialarray = FindSerial(listie, serialarray)
listlen1 = findlength(serialarray)
For count = 0 To listlen1 - 1
MsgBox serialarray(count)
Next
With actbook
listlen2 = findlength(listie)
For count1 = 0 To listlen1 - 1
MsgBox "Current Serial is" & " " & serialarray(count1)
For count2 = 0 To listlen2 - 1
If contains(listie(count2), CStr(serialarray(count1))) Then
listlen3 = findlength(listie(count2))
If listie(count2)(0) = "SSC" Then
Set selectrange = Sheets("SSC").range(Cells(SSCcurrentrow + SSCcounter, Colstart), Cells(SSCcurrentrow + SSCcounter, Colstart + listlen3 - 1))
With selectrange
.Value = listie(count2)
End With
SSCcounter = SSCcounter + 1
ElseIf listie(count2)(0) = "DSC" Then
Set selectrange = Sheets("DSC").range(Cells(DSCcurrentrow + DSCcounter, Colstart), Cells(DSCcurrentrow + DSCcounter, Colstart + listlen3 - 1))
With selectrange
.Value = listie(count2)
End With
DSCcounter = DSCcounter + 1
End If
End If
Next
SSCcurrentrow = SSCcurrentrow + SSCcounter + 6
DSCcurrentrow = DSCcurrentrow + DSCcounter + 6
'SSCcounter = 0
'DSCcounter = 0
Next
End With
End Sub
The portion of the code where the error arises is;
Set selectrange = Sheets("DSC").range(Cells(DSCcurrentrow + DSCcounter, Colstart), Cells(DSCcurrentrow + DSCcounter, Colstart + listlen3 - 1))
With selectrange
.Value = listie(count2)
End With
At the beginning of the macro that I open a new workbook to put all the data into, then I open and close the workbooks containing the data, then return to the new workbook that was created. There is periodic saving happening over the course of the macro.
What can I do to fix this error?
Cells will reference the ActiveSheet in the ActiveWorkbook. Those objects might not be set, and they might not be on Sheet DSC. Try this instead:
With actbook.Sheets("DSC")
Set selectrange = range(.Cells(DSCcurrentrow + DSCcounter, Colstart), .Cells(DSCcurrentrow + DSCcounter, Colstart + listlen3 - 1))
End With
Or, a more readable version might be
Set selectrange = actbook.Sheets("DSC").Cells(DSCcurrentrow + DSCcounter, Colstart)
Set selectrange = selectrange.resize(1, listlen)