I am getting the 1004 error when running. The error is at this line:
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
What I want to do is to select the sheet (CTRYNAME) and then search through columns 5,7,9 etc and format the numbers as done in the code.
Public Sub MoM_Check()
Dim inti As Integer
Dim intj As Integer
Dim k As Integer
Dim mnth As Integer
Dim currSALE As Double
Dim prevSALE As Double
Dim diffpercent As Double
Dim CTRYname As String
Dim x As Integer
Dim column As String
'Find Difference percentage between sales of 24 common months in present month's extarct and previous month's extract
For n = 1 To 13
Application.SheetsInNewWorkbook = 4
Set wkbTemp = Workbooks.Add
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
'Open a temporary workbook to do all the Calculations
'First the current month's extract is copied to the first sheet
'We now copy sheets for range from wkbout to wkbtemp using usedrange
wkbCurr.Sheets(CTRYname).Activate
wkbCurr.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet1").Range("A1").PasteSpecial
wkbprev.Sheets(CTRYname).Activate
wkbprev.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet2").Range("A1").PasteSpecial
'open the Previous month's Main Extract file as given in the lookup tab. This data is pasted on sheet2 of temporary workbook.
'This sheet helps us to compare the country channels in current month's extract with the previous Month's Extract.
'So the same process is followed for this sheet and similarly we get the country channels from the previous month's extract and paste them on 'sheet3
'Prevcnt contains the number of country channels in the previous month's extract
k = 1
For mnth = 0 To 22
currSALE = wkbTemp.Sheets("Sheet1").Range("AB10").Offset(0, mnth).Value
prevSALE = wkbTemp.Sheets("Sheet2").Range("AC10").Offset(0, mnth).Value
If prevSALE = 0 And currSALE <> 0 Then
diffpercent = 1
ElseIf prevSALE = 0 And currSALE = 0 Then
diffpercent = 0
Else: diffpercent = (currSALE - prevSALE) / prevSALE
End If
If diffpercent > 0.01 Or diffpercent < -0.01 Then
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Incorrect"
Exit For
Else
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Correct"
k = k + 1
wkbRaw.SaveAs Filename:=strOutputQCPath & "Errorlog.xlsx"
wkbRaw.Close
End If
Next mnth
For x = 1 To 15
If x = 1 Or x = 2 Or x = 3 Or x = 4 Or x = 6 Or x = 9 Or x = 10 Or x = 11 Or x = 13 Then
GoTo Name
Else
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
If wkbCurr.Sheets(CTRYname).Range(column & x).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Range(column & x).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = "<-999%"
End If
End If
End If
Name:
Next x
wkbTemp.Close savechanges:=False
Set wkbTemp = Nothing
Next n
End Sub
Please help!
You haven't given the string "column" a value, which is why you're getting error 1004 on that line.
Related
The whole code works well until I set new opened workbook as wb and refer it to respected range. So suppose there is nothing wrong with my If and EndIf position.I tried several times with different way. With wb , ... Object-defined error. I remove .Value from Score, it gives error. using long range statement instead of Score, also give error. Where should I change? Thank you
Option Explicit
Sub TryFloo()
Dim year As String, x As String, startdate As String, month As String
Dim first As Integer, second As Integer, addDay As Integer, daterow As Integer
Dim mainbk As Workbook, wb As Workbook
Dim r&, i&, m As Integer
Dim path As String
Dim Score As Range
Set mainbk = Workbooks("kumpul mean.xlsm")
r = 5
With mainbk
If IsError(.Sheets(2).Range("E" & r)) Then '<---- Open first If()
Exit For
Else
year = ThisWorkbook.Sheets(2).Range("A" & r).Value
x = Range("C" & r).Value
addDay = Range("E" & r).Value - 1
first = InStr(x, "/")
second = InStr(first + 1, x, "/")
startdate = Mid(x, 1, 2)
month = Mid(x, first + 1, second - first - 1)
If month = 11 Then m = 1
If month = 12 Then m = 31
If month = 1 Then m = 62
End If
path = "E:\SouthNorth\1979.xls"
Set wb = Workbooks.Open(Filename:=path)
wb.Activate
daterow = m + startdate
For i = daterow To daterow + addDay
With wb
Score = .Sheets(1).Range(Cells(i, 24))'<--- Application/object-defined error
If Score.Value > 12 And Score.Value < 14 Then Worksheets("Sheet2").Range("C" & i).Value = 1
ElseIf Score.Value > 14 And Score.Value < 16 Then Worksheets("Sheet2").Range("C" & i).Value = 2
ElseIf Score.Value > 16 Then Worksheets("Sheet2").Range("C" & i).Value = 3
End If
End With
Next i
'wb.Close SaveChanges:=True '<- left open for checking
End If '<---- close first If()
End With
End Sub
wb.Range(Cells(i, 24)) is incorrect. The Cells is a property of a worksheet and not workbook.
Try something like this
wb.Sheets("Sheet1").Range("X" & i)
or
wb.Sheets("Sheet1").Cells(i,24)
I am trying to find the number of colourfilled cells in B coloumn. I want to count and display the number of cour filled coloumns
But I am getting error :
Dim sum As Long
Dim count As Long
sum = 0
count = 0
strFileName = Application.GetOpenFilename("Excel files (*.xls*),*.xl*", Title:="Open data")
Set Target = Workbooks.Open(strFileName)
Set tabWS = Target.Worksheets("Tabelle1")
' lastrow = tabWS.Range("D" & tabWS.Rows.count).End(xlUp).Row 'Trigger Description starts from 2 row A coloumn
lastrow = tabWS.Range("B" & tabWS.Rows.count).End(xlUp).Row 'Trigger Description starts from 2 row A coloumn
For j = 2 To lastrow
If tabWS.Cells(j, 2).Interior.ColorIndex = 4 Then
sum = sum + tabWS.Cells(j, 8).value
count = count + 1
End If
Next j
MsgBox ("the value is" & sum)
End sub
I am getting error for sum = sum +tabs.cell(j,8).value
I can't figure it out whyI am getting this error. Can any one give me a suggestion
It looks to me like you're opening the Workbook each time you use a method on tabWS. Try setting tabWS equal to the following instead:
tabWS = Worksheets("Tabelle1")
Now when you're setting your lastrow and sum variables in the latter part of your code you won't be trying to open the workbook over and over again.
Edit (continued from comment below)*:
lastrow = Worksheets("Tabelle1").Range("B" & Worksheets("Tabelle1").Rows.count).End(xlUp).Row
For j = 2 To lastrow
If Worksheets("Tabelle1").Cells(j, 2).Interior.ColorIndex = 4 Then
sum = sum + Worksheets("Tabelle1").Cells(j, 8).value
count = count + 1
End If
Next j
MsgBox ("the value is" & sum)
End sub
I am trying to write a macro which search data from one sheet and copy's to another.
But now I have a problem because I want to copy data between two searches and paste the whole data from multiple cells into one single cell.
For example in the above picture my macro:
SEARCH for "--------------" and "*****END OF RECORD"
COPIES everything in between , here example data in row 29 and 30 and from column A,B,C
PASTE all the data from multiple cells A29,B29,C29 and then A30,B30,C30 to single cell in sheet 2 say cell E2.
This pattern is reoccurring in the column A so I want to search for the next occurrence and do all the steps 1,2,3 and this time I will paste it in Sheet2 , cell E3.
Below is the code:
I am able to search my pattern but hard time in giving references to the cells in between those searched patterns and then copying all the data to ONE cell.
x = 2: y = 2: Z = 7000: m = 0: n = 0
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "---------------------" Then m = x
If ThisWorkbook.Sheets("lic").Range("A" & x) = "****** END OF RECORD" Then n = x
If (n > 0) Then
Do
For i = m To n
ThisWorkbook.Sheets("lic").Range("A" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("B" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("C" & i + 1).Copy
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y) = ThisWorkbook.Sheets("lic").Range("A" & m + 1, "C" & n - 1): y = y + 1
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y).Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value: y = y + 1
Loop While Not x > Z
'Driver's Licence #:Driver's Licence #:Driver's Licence #:
x = 2: y = 2: Z = 7000: counter = 1
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "Driver's Licence #:" Then counter = counter + 1
If (counter = 2) Then ThisWorkbook.Sheets("Sheet1").Range("B" & y) = ThisWorkbook.Sheets("lic").Range("C" & x): y = y + 1: counter = 0
If x = Z Then Exit Sub
Loop
End Sub
Considering that the search is working correctly, about the copy thing you just need to do:
Sheet2.Range("E2").value = ThisWorkbook.Sheets("lic").Range("A" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("B" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("C" & i + 1).value
The result will be something like: AIR COO; L DAT; A
--------UPDATE---------
It was hard to understand your code, so I'm write a new one. Basically it's copy what it found on sheet1 to sheet2.
Sub Copy()
Dim count As Integer 'Counter of loops to the for
Dim Z As Integer 'Limit of (?)
Dim h As Integer 'Count the filled cells on sheet2
Dim y As Integer 'Counter the columns to be copied
Z = 7000
h = 1
'Assuming that the "----" will always be on the top, the code will start searching on the second row
'if it's not true, will be needed to validate this to.
For count = 2 To Z
If Sheet1.Cells(count, 1).Value <> "****** END OF RECORD" Then
If Sheet1.Cells(count, 1).Value <> "" Then
For y = 1 To 3 'In case you need to copy more columns just adjust this for.
Sheet2.Cells(h, 1).Value = Sheet2.Cells(h, 1).Value & Sheet1.Cells(count, y).Value
Next y
h = h + 1
End If
Else
MsgBox "END OF RECORD REACHED"
Exit Sub
End If
Next count
End Sub
Maybe I don't get the full idea but this might work for you.
I'm not at all sure what you want to see in the final output, so this is an educated guess:
Sub DenseCopyPasteFill ()
Dim wsFrom, wsTo As Worksheet
Dim ur As Range
Dim row, newRow As Integer
Dim dataOn As Boolean
Dim currentVal As String
dataOn = False
newRow = 3
Set wsFrom = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
Set ur = wsFrom.UsedRange
For row = 1 To ur.Rows.Count
If wsFrom.Cells(row, 1).Value2 = "--------------" Then
dataOn = True
ElseIf wsFrom.Cells(row, 1).Value2 = "***** END OF RECORD" Then
newRow = newRow + 1
dataOn = False
ElseIf dataOn Then
currentVal = wsTo.Cells(newRow, 5).Value2
wsTo.Cells(newRow, 5).Value2 = currentVal & _
wsFrom.Cells(row, 1) & wsFrom.Cells(row, 2) & _
wsFrom.Cells(row, 3)
End If
Next row
End Sub
If you can get away without using the Windows clipboard, I would. Instead of copy/paste, here I demonstrated how you can simply add or append a value.
Add this sub:
Sub copy_range(rng As Range)
Dim str As String
str = rng.Cells(1).Value & rng.Cells(2).Value & rng.Cells(3).Value
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1).Value = str
End Sub
Then your for loop should look like this:
For i = m To n
copy_range ThisWorkbook.Sheets("lic").Range("A" & i + 1 & ":C" & i + 1)
Next i
I'm currently writing a sub but I'm unclear of how to approach the problem programatically
Essentially I have a sheet with a column of data values starting at "A1"
How do I write a sub that will check through the column to find the largest pattern starting from the first cell and the direction of the pattern?
ie. if A1 is 2, A2 is 5, A3 is -2 ... the sub should return 2 (positive 2 days in a row)
if A1 is -2, A2 -1, A3 is -5, A4 is -2, A5 -1, A6 2 ... the sub should return -5 (negative 5 days in a row)
What I want is to somehow gather this number but in the process also save the last row in the pattern so I can compute averages, std variation etc. to store to a collection
Here is the code to check for patterns.... the j is a column counter... I need to figure out how to make the loop go back up to right before the for loop instead of iterating the j variable and then going back down....
but in any case here is the check pattern sub
<i> Sub pattern_recogADR()
'add back in as parameters
x As Long
pat_days As Long
sht_start As Long
x = 1
pat_days = 5
sht_start = 13
Dim st As Long
Dim st_num As Long
Dim st_end As Long
Dim count As Long
Dim patrn As Long
count = sht_start
Dim i As Long
Set pat = New pattern
For j = 8 To 12
st_num = 0
If IsNumeric(Cells(count, j).value) Then
st_num = count 'sets default pattern to beginning cell value
If Cells(st_num, j).value < 0 Then
For i = count + 1 To count + 1 + pat_days
If IsNumeric(Cells(i, j).value) And Cells(i, j).value < 0 Then
st_end = i
Else
Exit For
End If
Next i
patrn = st_end - st_num
tix.arbPnl = patrn
'**CONFUSION HERE WANT TO SAVE PATTERN TO AN EXISTING COLLECTION STARTING `
'AT THE FIRST ITEM **
ElseIf Cells(st_num, j).value > 0 Then
For i = count + 1 To count + 1 + pat_days
If IsNumeric(Cells(i, j).value) And Cells(i, j).value < 0 Then
st_end = i
Else
Exit For
End If
Next i
patrn = st_end - st_num
TIX.arbPnl = patrn
'save to separate class for patterns
Else
count = count + 1
End If
Next j
End Sub
Here is where I previously define the object. Basically I want to get this pattern and then add it to the respective attribute (? I dont know coding vocab) in this collection which is already define so the pattern matches with the respective item in the collection.
Option Explicit
Public TixCollection As New Collection
Sub DefineTixCollection()
Application.ScreenUpdating = False
Sheets("Input").Activate
Set TixCollection = Nothing
Dim tix As clsTix
Dim i As Long
Dim last_row As Long
last_row = Range("A" & Rows.count).End(xlUp).Row
'Add tix properties
For i = 3 To last_row
Set tix = New clsTix
'only adds active tickers to collection
If Range("A" & i).value = "x" Then
'Random data
tix.ORD = Range("B" & i).value
tix.ADR = Range("C" & i).value
tix.ratio = Range("D" & i).value
tix.crrncy = Range("E" & i).value
tix.hedge_index = Range("F" & i).value
tix.hedge_ord = Range("G" & i).value
tix.hedge_ratio = Range("H" & i).value
' ADR is the id key
TixCollection.Add tix, tix.ADR
End If
Next i
' Error Check
' For i = 1 To 5
' 'retrieve by collection index
' Debug.Print TixCollection(i).ORD
' Debug.Print TixCollection(5).ADR
' Debug.Print TixCollection(5).ratio
' Debug.Print TixCollection(i).crrncy
' Debug.Print TixCollection(i).hedge_index
' Debug.Print TixCollection(i).hedge_ord
' Debug.Print TixCollection(i).hedge_ratio
' Next i
End Sub
Any help would be much appreciated getting frustrated now... ugh
Sub Button1_Click()
Dim patrn() As Long
ReDim patrn(0 To 4)
Dim count As Long
Dim posCount As Integer
Dim negCount As Integer
Dim sign As Boolean
posCount = 0
negCount = 0
count = 0
Dim i As Long
Dim j As Integer
Dim lastRow As Long
For j = 8 To 12
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.count, j).End(xlUp).Row
For i = 1 To lastRow
If IsNumeric(Cells(i, j).Value) Then
If count = 0 Then
If Cells(i, j).Value > 0 Then
sign = True
posCount = posCount + 1
ElseIf Cells(i, j).Value < 0 Then
sign = False
negCount = negCount + 1
End If
ElseIf count > 0 And count <= 4 Then
If Cells(i, j).Value > 0 And sign = True Then
sign = True
posCount = posCount + 1
ElseIf Cells(i, j).Value > 0 And sign = False Then
sign = True
posCount = 1
ElseIf Cells(i, j).Value < 0 And sign = True Then
sign = False
negCount = 1
ElseIf Cells(i, j).Value < 0 And sign = False Then
sign = False
negCount = negCount + 1
End If
ElseIf count = 5 Then
Exit For
End If
count = count + 1
End If
Next i
If posCount > negCount Then
patrn(j - 8) = posCount
Else
patrn(j - 8) = negCount - (negCount * 2)
End If
negCount = 0
posCount = 0
count = 0
Next j
'Do your other calculations here.
For i = LBound(patrn) To UBound(patrn)
Debug.Print patrn(i)
Next
End Sub
Sub Add_sumf()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
For Each y In bb.Range("A:A")
On Error GoTo Label
If UCase(bb.Cells(j, "A").Value) <> "" Then
cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), aa.Range("B:B"), UCase(bb.Cells(1, k).Value), aa.Range("G:G"), UCase(bb.Cells(j, "A").Value))
bb.Cells(j, k).Value = TimeValue(cellDate1)
cellDate1 = TimeValue("00:00:00")
bb.Cells(j, k).NumberFormat = "[h]:mm:ss"
On Error GoTo Label
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
I am using above code to add time duration based upon value of two other columns but I always get 00:00:00 as result.
if i use below code i get the answer but its too slow very slow
Sub add_it_time()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
'MsgBox bb.Cells(1, k).Value
For Each y In bb.Range("A:A")
On Error GoTo Label
' MsgBox UCase(bb.Cells(j, "A").Value)
If UCase(bb.Cells(j, "A").Value) <> "" Then
For Each x In aa.Range("F:F")
On Error Resume Next
If UCase(aa.Cells(i, "B").Value) = UCase(bb.Cells(j, "A").Value) Then
' MsgBox aa.Cells(i, "F").Text
' total = total + Int(get_Second(aa.Cells(i, "F").Text))
If UCase(aa.Cells(i, "G").Value) = UCase(bb.Cells(1, k).Value) Then
'MsgBox aa.Cells(i, "F").Text
cellDate1 = cellDate1 + TimeValue(aa.Cells(i, "F").Value)
End If
End If
i = i + 1
Next
i = 3
On Error GoTo Label
bb.Cells(j, k).NumberFormat = "h:mm:ss"
bb.Cells(j, k).Value = WorksheetFunction.Text(cellDate1, "[hh]:mm:ss")
total = 0
cellDate1 = 0
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
The source column which contains date is of general formatt
I am new to VBA macros
UPDATED SOLUTION:
After discussion in chat with OP it was decided that pure formula solution is fine - below are formulas / actions to do on the separate sheet starting A1:
Row A will be resulting table header: in A1 I added Agent Name / Release Code, and starting B1 there's a list of all available Release Code values (easily got using Remove Duplicates).
I defined the following named ranges for the simplicity and effectiveness (since initial data is NOT static): AgentNames=OFFSET('Agent State'!$B$2,0,0,COUNTA('Agent State'!$B:$B)-1,1) - this will return the range of names on the initial sheet excluding the header; TimeInStateData=OFFSET(AgentNames,0,4) and ReleaseCodes=OFFSET(AgentNames,0,5) as shifted AgentNames range.
In column A we should obtain the list of names, which should be unique, so select in column A any number of cells which is NOT less that number of unique names - for the sample I used A2:A51, and type that formula: =IFERROR(INDEX(AgentNames,SMALL(IF(MATCH(AgentNames,AgentNames,0)=ROW(INDIRECT("1:"&ROWS(AgentNames))),MATCH(AgentNames,AgentNames,0),""),ROW(INDIRECT("1:"&ROWS(AgentNames))))),"") and press CTRL+SHIFT+ENTER instead of usual ENTER - this will define a Multicell ARRAY formula and will result in curly {} brackets around it (but do NOT type them manually!).
B2: =IF(OR($A2="",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))=0),"",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))) - normal formula, which will return empty value for either empty name or zero time.
Copy formula from B2 to the whole table.
Remarks:
Resulting range for the sum of time values should be formatted as Time.
If the list of names should be expanded in the future - repeat step 3 for the new range, but do NOT drag the formula down - this will result in You cannot change part of an array error.
Sample file: https://www.dropbox.com/s/quudyx1v2fup6sh/AgentsTimeSUM.xls
INITIAL ANSWER:
Perhaps that's too simple and obvious, but at a glance I don't understand why you have that line of code:
cellDate1 = TimeValue("00:00:00")
right after your SUMIFS: cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), ...
Try to remove the first one where you assign zeros to cellDate1.