I've created a particularly long vba macro to edit a large spreadsheet of data for me instead of doing it myself thousands of times. The code for the actual editing works fine, however, when I add in the first if statements and first while loop to make it loop through the whole spreadsheet, I get a runtime error 1004. I'm new to vba but I'm pretty sure there is an error in my logic rather than the code itself. I've marked which lines of code cause the error when added.
Sub RCFS()
Dim ProfCtr As String
Dim Year As String
Dim Amount As Currency
Dim Period As Long
Dim S2FreecellH As Long
Dim ProfCenCellH As Long
Dim FreeCellClone As Long
Dim Clone2 As Long
Dim Clone3 As Long
Dim y As Long ' placeholder 2
y = 1
S2FreecellH = 3
ProfCenCellH = 2
AmountH = 2
PeriodH = 2
YearH = 2
ProfCtr = Cells(ProfCenCellH, 4)
Year = Cells(YearH, 7)
Amount = Cells(AmountH, 8)
Period = Cells(PeriodH, 6)
'//////////////////////////////////////////////////////////////////////////////////
While IsEmpty(Cells(ProfCenCell, 4).Value) = False
Everything fine until this while loop (above) and if statement (below). The rest works fine without these 2 statements but I need it to loop through the whole spreadsheet.
If Cells(ProfCenCell, 4).Value = Worksheets("Sheet2").Cells(S2FreecellH, 1).Value Then
Worksheets("Sheet2").Cells(S2FreecellH, 1).Value = ProfCtr
Worksheets("Sheet2").Cells(S2FreecellH, 5).Value = ProfCtr
Worksheets("Sheet2").Cells(S2FreecellH, 9).Value = ProfCtr
FreeCellClone = S2FreecellH 'setting clones
Clone2 = S2FreecellH
Clone3 = S2FreecellH
For x = S2FreecellH + 1 To S2FreecellH + 12
Worksheets("Sheet2").Cells(x, 2).Value = y 'Creating 1 to 12 numbering in column 1
Worksheets("Sheet2").Cells(x, 6).Value = y 'Creating 1 to 12 numbering in column 2
Worksheets("Sheet2").Cells(x, 10).Value = y 'Creating 1 to 12 numbering in column 3
S2FreecellH = S2FreecellH + 1
y = y + 1
Next x
While Worksheets("Sheet2").Cells(FreeCellClone, 1).Value = Cells(YearH, 4).Value 'Loop to input all amounts
Worksheets("Sheet2").Cells(FreeCellClone + Period, (((Year Mod 11) * 4)) - 1).Value = Amount 'Calculation on post year to select correct column to post amount in
PeriodH = PeriodH + 1
AmountH = AmountH + 1
YearH = YearH + 1
Year = Cells(YearH, 7)
Amount = Cells(AmountH, 8)
Period = Cells(PeriodH, 6)
Wend
Worksheets("Sheet2").Cells(S2FreecellH + 1, 3) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 3), Worksheets("Sheet2").Cells(S2FreecellH, 3)))
Worksheets("Sheet2").Cells(S2FreecellH + 1, 7) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 7), Worksheets("Sheet2").Cells(S2FreecellH, 7))) 'Creating sums for all 3 columns
Worksheets("Sheet2").Cells(S2FreecellH + 1, 11) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 11), Worksheets("Sheet2").Cells(S2FreecellH, 11)))
For Z = Clone2 + 1 To Clone2 + 12 'creating intitial percentage values
Worksheets("Sheet2").Cells(Z, 4).Value = Format((Worksheets("Sheet2").Cells(Z, 3) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 3)) * 100, "%0.00")
Worksheets("Sheet2").Cells(Z, 8).Value = Format((Worksheets("Sheet2").Cells(Z, 7) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 7)) * 100, "%0.00")
Worksheets("Sheet2").Cells(Z, 12).Value = Format((Worksheets("Sheet2").Cells(Z, 11) / Worksheets("Sheet2").Cells(S2FreecellH + 1, 11)) * 100, "%0.00")
Next
For q = Clone3 + 1 To Clone3 + 12 'creating final percentage values
Worksheets("Sheet2").Cells(q, 13).Value = Format(((Worksheets("Sheet2").Cells(q, 4) + Worksheets("Sheet2").Cells(q, 8) + Worksheets("Sheet2").Cells(q, 12)) / 3) * 100, "%0.00")
Next q
Worksheets("Sheet2").Cells(S2FreecellH + 1, 13) = WorksheetFunction.Sum(Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(FreeCellClone + 1, 13), Worksheets("Sheet2").Cells(S2FreecellH, 13)))
Else
ProfCenCell = ProfCenCell + 1
End If
'/////////////////////////////////////////////////////////////////////////////// Loop these Loops
S2FreecellH = S2FreecellH + 3
y = 1
Wend
End Sub
You never set a value for ProfCenCell, hence it has default value 0. Then, you use Cells(ProfCenCell, 4) which is in your case Cells(0, 4) and that 0 makes a problem.
Related
Sub blockofdatatoreport()
Dim i As Integer
Dim x As Integer
Dim y As Integer
For i = 1 To 95
actvrw = Sheet1.Range("A:A").Find(what = i, searchdirection = xlNext).Row
'searching cells top to bottom
lr = Sheet2.Range("A:A").Find(what = "*", searchdirection = xlprevious).Row + 1
'searching cells bottom to top
For x = 1 To 5
Sheet2.Cells(lr, 1).Value = Sheet1.Cells(actvrw + (x - 1), 3).Value
'looping the first five columns in sheet2
Next
For y = 1 To 4
Sheet2.Cells(lr, 5 + y).Value = Sheet1.Cells(actvrw + (y - 1), 6).Value
'looping the next four columns after the first four is done in sheet2
Next
'You can also write like this or write a loop in two lines above.
'Sheet2.Cells(lr, 1).Value = Sheet1.Cells(actvrw, 3).Value
'Sheet2.Cells(lr, 2).Value = Sheet1.Cells(actvrw + 1, 3).Value
'Sheet2.Cells(lr, 3).Value = Sheet1.Cells(actvrw + 2, 3).Value
'Sheet2.Cells(lr, 4).Value = Sheet1.Cells(actvrw + 3, 3).Value
'Sheet2.Cells(lr, 5).Value = Sheet1.Cells(actvrw + 4, 3).Value
Next
End Sub
I get error called error 13 y type mismatch, what is in the above code causing the error??
I have to insert missing dates to a row without deleting the duplicated dates (for a billing program). Example data:
DATE
01/02/2016
02/02/2016
03/02/2016
03/02/2016
03/02/2016
06/02/2016
07/02/2016
08/02/2016
My code is infinitely looping and deleting the duplicate dates. Why does this happen?
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
If Cells(i, 1) + 1 <> Cells(i + 1, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
i = i + 1
Loop Until Cells(i + 1, 1) = "31.10.2016"
End Sub
Here is the code modified with comments to address your issues
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
'Use less then instead of <> so it doesn't flag duplicate cells
If Cells(i, 1) + 1 < Cells(i + 1, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
'Second check to add value if the next row is blank
If (Cells(i + 1, 1) = "") Then
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
i = i + 1
'Changed the loop function from cells(i+1,1) to cells(i,1) since you already
'incremented i
'Also made the date check slightly more robust with dateserial
Loop Until Cells(i, 1).Value >= DateSerial(2016, 1, 30)
End Sub
I need to copy a lot of rows. I tried to do something.copy something else.paste but it's extremely slow
I tried to do
Range(..).value(formula) = Range(..).value(formula) but its not so good because i have a date there that turn to ######
I need a faster way to do this copy/paste
This is my code:
Function Last_Col(k As Long) As Long
Last_Col = Cells(k, Columns.Count).End(xlToLeft).Column
End Function
Function Last_Col_Doc() As Long
Last_Col_Doc = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Column
End Function
Function Is_Grouped(i As Long) As Boolean
Is_Grouped = (Cells(i, 2).Rows.OutlineLevel > 1)
End Function
Function Is_Bold(i As Long) As Boolean
Is_Bold = Cells(i, 2).Font.Bold
End Function
Function Print_NA(i As Long, k As Long) As Boolean
Range(Cells(i, 21), Cells(i, 21 + k - 2)).Value = "NA"
End Function
Function Last_Row() As Long
Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
End Function
Sub EditParanoia()
Dim FrstBlkRow As Long
Dim flag As Boolean
Dim i As Long
Dim HeadLen As Long
FrstBlkRow = Last_Col(1) + 1
If FrstBlkRow < 25 Then 'first edit
flag = True
i = 2
Do While flag
If Is_Bold(i) Then
flag = False
Else
i = i + 1
End If
Loop
HeadLen = Last_Col(i)
Range(Cells(i, 2), Cells(i, HeadLen)).Copy
Range(Cells(1, FrstBlkRow), Cells(1, FrstBlkRow + HeadLen - 2)).PasteSpecial
Else
FrstBlkRow = 21
HeadLen = 10
End If
Dim j As Long
For i = 2 To Last_Row Step 1
If Not Is_Grouped(i) And Not Is_Grouped(i + 1) And Cells(i, FrstBlkRow + 1).Value = vbNullString Then
'if not part of group
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 2)).Value = "NA"
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) And Is_Grouped(i + 2) And Not Is_Grouped(i + 3) Then
'if Part of group of 1 val
Range(Cells(i + 2, 2), Cells(i + 2, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 3)).PasteSpecial
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) Then
'if part of group of more then one val
j = 1
Do Until Is_Grouped(i + j) And Not Is_Grouped(i + j + 1)
'j will get the langth of any group
j = j + 1
Loop
'past the relevant cell in the right place
Range(Cells(i + 2, 2), Cells(i + 2 + j - 1 - 1, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i + j - 1 - 1, FrstBlkRow + HeadLen - 3)).PasteSpecial
'past the head respectively
Range(Cells(i, 1), Cells(i, 20)).Copy
Range(Cells(i + 1, 1), Cells(i + j - 2, FrstBlkRow - 1)).PasteSpecial
End If
Next
End Sub
When you say you've tried "Range(..).value(formula) = Range(..).value(formula)", what do you mean? You should be able to set two ranges equal to eachother:
Say A1:A10 has "Batman, 10-01-2015" and you want to copy that range to B1:B10, Range("B1:B10").Value = Range("A1:A10").Value. You can't do that? I tried it with dates, and it set the B range values to dates, no reformatting necessary.
I also notice in your code, you PasteSpecial, but don't specify what type of special paste. See the Microsoft (or this one) page for more info.
I'm trying to add the items from a list to some rows in an Excel Sheet.
I tried to do it this way:
Dim Rand As Long
Dim ws As Worksheet
Set ws = Worksheets("Necmontage")
Rand = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Range(ws.Cells(Rand, 1), ws.Cells(Rand + necesar.ListCount - 1, 1)).Merge
ws.Cells(Rand, 1) = "K"
Range(ws.Cells(Rand, 2), ws.Cells(Rand + necesar.ListCount - 1, 2)).Merge
ws.Cells(Rand, 2) = "Montage"
Range(ws.Cells(Rand, 3), ws.Cells(Rand + necesar.ListCount - 1, 3)).Merge
ws.Cells(Rand, 3) = comanda.Caption
Dim i As Integer
i = 0
Do While i = necesar.ListCount - 1
ws.Cells(Rand + i, 4) = necesar.List(i, 0)
i = i + 1
Loop
End Sub
It adds all the values I want except the values from the List (where I do that While Loop). I don't know why but it doesn't take the values. Any idea about this problem?
Did you mean in your code:
Do While i <= necesar.ListCount - 1 'instead of =
ws.Cells(Rand + i, 4) = necesar.List(i, 0)
i = i + 1
Loop
Btw, you can see in debug mode by putting a breakpoint on the Do While line if the program goes where you wanted it to.
Need to print a table of any numbers using VBA in excel. i.e blank row after each row . Below iswhat i wrote to print a table in consecutive rows, But i dont know how can i print the result in alternate rows?
Sub table()
a = InputBox("Enter first no")
ActiveSheet.Cells.Clear
ActiveSheet.Cells(5, 4) = "TABLE OF " & a
For i = 1 To 10
c = a * i
ActiveSheet.Cells(i + 5, 4) = a
ActiveSheet.Cells(i + 5, 5) = "*"
ActiveSheet.Cells(i + 5, 6) = i
ActiveSheet.Cells(i + 5, 7) = "="
ActiveSheet.Cells(i + 5, 8).Value = c
next i
End Sub
Sub table()
a = InputBox("Enter first no")
n As Integer
n=6
ActiveSheet.Cells.Clear
ActiveSheet.Cells(5, 4) = "TABLE OF " & a
For i = 1 To 10
c = a * i
ActiveSheet.Cells(n, 4) = a
ActiveSheet.Cells(n, 5) = "*"
ActiveSheet.Cells(n, 6) = i
ActiveSheet.Cells(n, 7) = "="
ActiveSheet.Cells(n, 8).Value = c
n = n + 2
next i
End Sub
Change your row number calculation from
i + 5
to
(i * 2) + 4