In the Excel VBA debugger I am getting a
1004 Application-defined or object-defined error.
The line with the error is marked with a note below. I believe that the .Range(Cells(2, j + 1)) object is causing the error but I believe that my syntax is correct. So, I am unsure why this error is occurring.
Option Explicit
Sub Macro2()
Dim i as Integer, j As Integer, lrow As Long, rng As Range, cell As Range, size as Integer
Sheets("Std. BOMs").Select
size = Application.WorksheetFunction.CountIf(Range("F3:F999"), "Total")
ReDim arrVal(1 To size) As Long
lrow = Cells(Rows.Count, "F").End(xlUp).Row
set rng = Range("F3:F" & lrow)
For j = 0 To 1991
j = j + 1
ActiveSheet.Range(ActiveSheet.Cells(j,23), ActiveSheet.Cells(j,24)).Select
Selection.Copy
Range("E1:F1").Select
ActiveSheet.Paste
ActiveSheeet.Cells(j,25).Select
Selection.Copy
Range("G1").Select
ActiveSheet.Paste
i = 0
For Each cell In rng
If Application.WorksheetFunction.ISNA(cell) Then
Exit For
ElseIF InStr(1, cell.Value, "Total", vbTextCompare) > 0 Then
i = i + 1
arrVal(i) = cell.Offset(0,1).Value
End If
Next cell
Sheets("Matrix").Range(Cells(2, j + 1)).Resize(i, 1).Value = Application.Transpose(arrVal) '---------Line with 1004 Error----------'
Next j
Application.CutCopyMode = False
ActiveWindow.ScrollRow = 1
Range("H7").Select
End Sub
Try changing that line to
Sheets("Matrix").Cells(2, j + 1)).Resize(i, 1).Value = Application.Transpose(arrVal)
Range() requires 2 Cells
Related
I want to increment the decimal part of a number and restart numbering every time the number changes as below
1.00
1.01
1.02
1.03
1.04
1.05
2.00 'Restart With 2
2.01
3.00 'Restart With 3
3.01
3.02
3.03
I used the following Code
Sub AutoNumberDecimals()
Dim Rng, C As Range
Dim Lrow As Long
Dim i As Integer
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Worksheets("Union").Range("A2:A" & Lrow)
For Each C In Rng.Cells
If C.Value = "" And C.Offset(0, 1).Value = "" Then
C.Offset(1, 0).Value = C.Value + 0.01
Next C
End Sub
But It did not work
Appreciate your help
Thanks, Regards
I wrote this code. Make sure to add it in Sheet1 module (or similar sheet). It reacts when you enter a number in column 1 and it renumbers all numbers in that column. If you enter 1, it shows 1.00... if you enter 1 again, it will show 1.01. If you enter 2 you will have 2.00 etc...
Private ChangingValues As Boolean
Private Sub RenumFirstColumn()
Dim RowNo As Integer
Dim Major As Integer
Dim Minor As Integer
Dim CurrentValue As String
RowNo = 1
Major = 1
Minor = 0
Do
CurrentValue = CStr(Cells(RowNo, 1).Value)
If Int(Val(Left(CurrentValue, 1))) = Major Then
CurrentValue = CStr(Major) & "." & Format(Minor, "00")
Minor = Minor + 1
If Minor > 99 Then
MsgBox "To high value (> X.99)"
Exit Sub
End If
Else
Major = Val(Left(CurrentValue, 1))
Minor = 0
CurrentValue = CStr(Major) & "." & Format(Minor, "00")
Minor = Minor + 1
End If
Cells(RowNo, 1).NumberFormat = "#"
Cells(RowNo, 1).Value = CurrentValue
RowNo = RowNo + 1
Loop Until IsEmpty(Cells(RowNo, 1))
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And ChangingValues = False Then
ChangingValues = True
RenumFirstColumn
ChangingValues = False
End If
End Sub
Hope it was what you were looking for
Try the next code, please. It uses maxIncr variable to set a maximum incrementing times:
Sub IncrementingRoots()
Dim sh As Worksheet, lastR As Long, maxIncr As Long
Dim NrI As Long, i As Long, j As Long
Set sh = ActiveSheet: maxIncr = 7
lastR = sh.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lastR + maxIncr
If sh.Range("A" & i).Value <> "" Then
NrI = sh.Range("A" & i).Value
For j = 1 To maxIncr
If sh.Range("A" & i + j).Value = Empty Then
sh.Range("A" & i + j).Value = sh.Range("A" & i + j - 1).Value + 0.01
Else
i = j + i - 1: Exit For
End If
Next
End If
If i > lastR Then Exit For
Next i
End Sub
And the next code is yours adapted to work. But impossible to procress the last number in the range, too, without something more (like maxIncr in my above code)...
Sub AutoNumberDecimals()
Dim sh As Worksheet, Rng As Range, C As Range, Lrow As Long, i As Long
Set sh = ActiveSheet 'Worksheets("Union")
Lrow = sh.cells(Rows.count, 1).End(xlUp).Row
Set Rng = sh.Range("A2:A" & Lrow)
For Each C In Rng.cells
If C.Value = "" And (C.Offset(1, 0).Value <> _
Int(C.Value Or C.Offset(1, 0).Value = "")) Then
C.Value = C.Offset(-1, 0).Value + 0.01
End If
Next C
End Sub
This uses DataSeries and NumberFormat to fill the cells.
This creates a random board, and isn't necessary to the main code.
Cells.Clear
Cells(1, 1) = 1 ' creates a random board
x = 2
For i = 2 To 20
If Rnd() > 0.8 Then
Cells(i, 1) = x
x = x + 1
End If
Next i
Cells(21, 1) = 0 ' terminates entries
Note that rather than determine the row column length using code, I have preset it to 21, although you can use the terminating 0.00 value to define a column length.
The main code:
Range("a:a").NumberFormat = "0.00"
For i = 1 To 21 ' loops through range
j = 0 ' finds local range
If Cells(i, 1) <> "" And Cells(i, 1) > 0 Then
Do
j = j + 1
Loop While Cells(i + j, 1) = ""
End If
Range(Cells(i, 1), Cells(i + j - 1, 1)).DataSeries Type:=xlLinear, Step:=0.01
i = i + j ' jumps to next entry
Next i
Each cell is formatted into the desired style. Then the loop finds a non-empty cell, and determines the associated local subrange by checking if the next cell down is empty or not, and continues until it isn't. Then the subrange is formatted using DataSeries with a Step of 0.01.
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.range.dataseries
I've got dates in Row 2 and have the following code to insert a column based on whether the date in B1 is less than the date in B2, C2, etc....
Sub Test3()
If DateValue(Cells(1, 2).Value) < DateValue(Cells(2, 2).Value) Then
Range("B2").EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")
ElseIf DateValue(Cells(1, 2).Value) < DateValue(Cells(2, 3).Value) Then
Range("C2").EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")
End If
End Sub
The above code works and adds a column at the right place and puts a date in row 2 of the column.
Obviously it would be much easier for me to loop this but I am having trouble getting the loop to work. Here is what I have so far:
Sub DateLoopTest()
Dim i As Integer
i = 1
Do Until DateValue(Cells(1, 2).Value) < DateValue(Cells(2, i + 1).Value)
Cells(2, i + 1).EntireColumn.Select
i = i + 1
Loop
ActiveCell.EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")
End Sub
I am getting Run-Time error '13': Type mismatch
No matter how much I mess with it I can't get it to loop like I want in my 1st example. Any suggestions
you can refer to this code:
Sub DateLoopTest()
Dim i As Integer
i = 0
'Loop from [B2] offset 0 to 1,2... -> then stop at [b2].offset(0,i)
Do Until (DateValue([b1]) < DateValue(IIf(IsDate([b2].Offset(0, i)), [b2].Offset(0, i), [b1])))
i = i + 1
Loop
[b2].Offset(0, i).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
[b2].Offset(0, i).Value = [b1]
End Sub
maybe i got it wrong because i'm just looking at your code, try this again, hope it helps :)
Sub DateLoopTest1()
Dim i As Integer, isCellhere As Boolean, isExistCell As Boolean, isRecentday As Boolean: i = 0:
isRecentday = True
'get lastCell index for Loop
Dim iLast As Integer: iLast = Cells(2, 15000).End(xlToLeft).Column
Dim iMax As Integer: iMax = 2 'default
Dim Cellmax As Range: Set Cellmax = [b2] 'default
Dim Datedefault As Variant: Datedefault = #1/1/1000#
If iLast = 1 Then Exit Sub
'Loop until CellMax
For i = 0 To iLast - 2
isCellhere = Datedefault < DateValue(IIf(IsDate([b2].Offset(0, i)), [b2].Offset(0, i), Datedefault))
'stop if True
If isCellhere Then Set Cellmax = [b2].Offset(0, i): Datedefault = DateValue([b2].Offset(0, i).Value)
Next i
Cellmax.EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cellmax.Offset(0, -1).Value = [b1]
End Sub
I've got a function which merges cells in table if whole range has the same value (eg. if A1:G1 is equal to A2:B2 it will merge cells like A1&A2, B1&B2 etc. More here: How to check if two ranges value is equal)
Now I would like, to change color on table created by that funcion, like first row (doesn't matter if merged or no) filled with color, second blank etc. but I have no idea whether I should color it with merging function or create another which will detect new table with merged rows as one etc. Below is my code:
Sub test()
Dim i As Long, j As Long, k As Long, row As Long
row = Cells(Rows.Count, 2).End(xlUp).row
k = 1
For i = 1 To row Step 1
If Cells(i, 1).Value = "" Then Exit For
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
k = i + 1
End If
Next i
End Sub
Try:
Option Explicit
Sub test1()
Dim LastColumn As Long, LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow Step 2
.Range(Cells(i, 1), .Cells(i, LastColumn)).Interior.Color = vbGreen '<- You could change the color
Next i
End With
End Sub
Before:
After:
Edited Solution:
Option Explicit
Sub test1()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight3"
End With
End Sub
Result:
So, after some time I've figured it out by myself. Below is the code:
Dim i As Long, j As Long, k As Long, l As Long, c As Integer
row = Cells(Rows.Count, 2).End(xlUp).row
k = 7
c = 1
For i = 7 To row Step 1
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
Select Case c
Case 0
Range(Cells(k, 1), Cells(k, 3)).Interior.Color = xlNone
c = 1
Case 1
For l = 0 To i - k Step 1
Range(Cells(k + l, 1), Cells(k + l, 3)).Interior.Color = RGB(217, 225, 242)
Next l
c = 0
End Select
k = i + 1
End If
Next i
I am not sure if the title is correct. Please correct me if you have a better idea.
Here is my problem: Please see the picture.
This excel sheet contains only one column, let's say ColumnA. In ColumnA there are some cells repeat themselvs in the continued cells twice or three times (or even more).
I want to have the excel sheet transformed according to those repeated cells. For those items which repeat three times or more, keep only two of them.
[Shown in the right part of the picture. There are three Bs originally, target is just keep two Bs and delete the rest Bs.]
It's a very difficult task for me. To make it easier, it's no need to delete the empty rows after transformation.
Any kind of help will be highly appreciated. Thanks!
#
Update:
Please see the picture. Please dont delete the items if they show again...
EDITED - SEE BELOW Try this. Data is assumed to be in "Sheet1", and ordered data is written to "Results". I named your repeted data (A, B, C, etc) as sMarker, and values in between as sInsideTheMarker. If markers are not consecutive, the code will fail.
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = k + 1
a = 2
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, 1).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
EDITION: If you want results in the same sheet ("Sheet1"), and keep the empty rows for results to look exactly as your question, try the following
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = i
a = 5
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 4).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
If you can delete the values that have more than two counts, then I suggest that this might work:
Sub count_macro()
Dim a As Integer
Dim b As Integer
a = 1
While Cells(a, 1) <> ""
b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))
If b > 2 Then
Cells(a, 1).Delete Shift:=xlUp
End If
b = 0
a = a + 1
Wend
End Sub
This should do it. It takes input in column A starting in Row 2 until it ends, and ignores more than 2 same consecutive values. Then it copies them in sets and pastes them transposed. If your data is in a different column and row, change the sourceRange variable and the i variable accordingly.
Sub SETranspose()
Application.ScreenUpdating = False
Dim sourceRange As range
Dim copyRange As range
Dim myCell As range
Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))
Dim startCell As range
Set startCell = sourceRange(1, 1)
Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True
For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1
If Cells(i, 1).Value = startCell.Value Then
If haveTwo Then
range(startCell, Cells(i, 1)).Copy
startCell.Offset(0, 4).PasteSpecial Transpose:=True
Application.CutCopyMode = False
haveTwo = False
End If
End If
'if the letter changes or end of set, then copy the set over
'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
If Len(Cells(i, 1).Value) > 1 Then
Set copyRange = Cells(i, 1)
copyRange.Copy
Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
Application.CutCopyMode = False
'Set startCell = sourceRange(i - 1, 1)
ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
Set startCell = sourceRange(i - 1, 1)
haveTwo = True
End If
Next i
'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing
Application.ScreenUpdating = True
End Sub
I have written a macro in excel, sometimes the macro works the way it should but about 40% of the times it hangs the complete excel and nothing happens. I tried to step through and most of the times I found the macro hands at 3 particular statements. can some one tell me what may be the exact thing i am doing wrong or how to better to make the macro more robust and stable.
here are the codes from the macro:
Sub fastcloudextractor()
'
' fastcloud extractor Macro
'
' defenitions
Dim data_arr() As Variant, temp_arr() As Variant
Dim i As Long, j As Long, k As Long, curent_item As Long
Dim pctCompl As Integer, err As Integer, total_items As Integer
Application.ScreenUpdating = False
err = 2
'
' get data row count and load data into array
'
Sheets("Original").Select
data_count = Range("A1").End(xlDown).Row
data_count = data_count + 1
Cells(data_count, 1) = 1
Cells(data_count, 5) = 1
data_arr = Range(Cells(2, 5), Cells(data_count, 14))
' without Below 2 Lines the program gives a error
'
Sheets("sheet4").Select
temp_arr = Range(Cells(1, 1), Cells(data_count, 10))
' ----- Begin new code -----
k = 1
current_item = data_arr(1, 1)
' Debug.Print current_item
For j = LBound(data_arr) To UBound(data_arr)
If data_arr(j, 1) = current_item Then
do some thing
Else
Do some thing else
End If
k = k + 1
Next j
Erase temp_arr
Erase data_arr
Sheets("Original").Select
Range("A2:N2").Select
Sheets("Unique").Select
Range("A2").Select
Sheets("Selected").Select
Range("A1").Select
Sheets("Compiled").Select
Range("A2").Select
Sheets("Extracted").Select
Range("A1").Select
Sheets("Magmi").Select
Application.ScreenUpdating = True
Application.StatusBar = False
Beep
MsgBox "Data Conversion Completed" & vbCr & "Total no of products is .." & total_items
End Sub
The Macro hangs normally at
data_arr = Range(Cells(2, 5), Cells(data_count, 14))
or
temp_arr = Range(Cells(1, 1), Cells(data_count, 10))
Can some one help me identify what I am doing wrong and how to correct it.
I am still a newbie so if corrections are mentioned kindly give code examples.
I find data_count = Range("A1").End(xlDown).Row very suspicious. In case there is only one row of data, your data_count will be equal to 1048576 and then with data_arr = Range(Cells(2, 5), Cells(data_count, 14)) you are filling this array with 10,485,760 values. That's a lot. It's better to use data_count = Range("A" & Rows.Count).End(xlUp).Row instead.