Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 7 years ago.
Improve this question
I have two Excels as an input. I am taking values from one excel and passing it as a parameter to other excel for applying filter. Once the filter is on, I am reading filtered values from a column and trying to match a condition as mentioned in the below code. And everything working fine up to this place. Once I get the specific match, I have to write it back to first Excel but I am getting runtime error while doing so.
strPath = "C:\Users\PSingh\Desktop\CodeInventory.xlsx"
strPath1 = "C:\Users\PSingh\Desktop\MyScripts\Processes.xlsx"
Dim rows
Set objExcel1 = CreateObject("Excel.Application")
objExcel1.Visible = True
Set objExcel2 = CreateObject("Excel.Application")
objExcel2.Visible = True
Set objDict = CreateObject("Scripting.Dictionary")
objDict.CompareMode = vbTextCompare
Const xlUp = -4162
Const xlCellTypeVisible = 12
Dim a(), val
objExcel1.Workbooks.Open(strPath1)
With objExcel1.Activeworkbook.Sheets("Sheet1")
rowcount = .Range("A" & .Rows.Count).End(xlUp).Row
MsgBox rowcount
End With
Redim Preserve a(rowcount)
For i=1 To rowcount
a(i) = objExcel1.Activeworkbook.Sheets("Sheet1").Cells(i,1).Value
objDict(a(i)) = a(i)
'msgbox a(i)
Next
n = objDict.Items
objExcel2.Workbooks.Open(strPath)
For i=0 To UBound(n)
With objExcel2.Activeworkbook.Sheets("All")
.Range("A1").AutoFilter 19, "="&n(i)
'rows=.usedrange.columns(1).specialcells(xlCellTypeVisible)
For Each cl In objExcel2.Activeworkbook.Sheets("All").UsedRange.Columns(12).SpecialCells(xlCellTypeVisible)
If (InStr(cl, "Seq") <> 0 Or InStr(cl,"seq")) <> 0 Then
objExcel1.Activeworkbook.Sheets("Sheet1").Cells(i,2) = "Data" 'Not Working
Exit For
End If
Next
End With
Next
Try it with,
objExcel1.Activeworkbook.Sheets("Sheet1").Cells(i + 1, 2) = "Data"
You loop with i begins at For i = 0 to .... There is no row zero in column B.
Related
I have a simple sub, where the data and the result look like this :
It's just to do a transpose value from data in column-A to column-B.
Sub test()
Dim rw1 As Long: Dim rw2 As Long: Dim cnt As Long
Dim kode1 As String: Dim kode2 As String
Dim oStop As Boolean
rw1 = 2: rw2 = 2: cnt = 1
Do
Do
If oStop = False Then
kode1 = Right(Split(Cells(rw1, 1).Value, ".")(0), 4)
kode2 = Left(kode1, 3) & LCase(Split(Columns(cnt).Address(0, 0), ":")(0))
If kode1 = kode2 Then
rw1 = rw1 + 1: cnt = cnt + 1
If Cells(rw1, 1).Value = "" Then oStop = True: kode1 = "X"
End If
End If
Loop Until kode2 <> kode1
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, cnt - 1) = Application.Transpose(Cells(rw2, 1).Resize(cnt - 1, 1).Value)
rw2 = rw1: cnt = 1
Loop Until Cells(rw1, 1).Value = ""
End Sub
The code runs and gives the expected result without error but the problem is, sometimes after I do some editing on the sheet (like changing the data, clear cell, etc) when I run the sub again, Windows show a circular blue icon spinning for maybe 1 second, then Excel close by itself without warning. When I open again the workbook, there's no result ... so I guess there's something wrong with the code which causing Excel close by itself before it has the chance to write the transpose value to column B.
And more problem, I can't replicate the "closing by itself". I mean, after I open the workbook again, do some editing on the sheet, run the sub (expecting Excel will close by itself) but Excel not close by itself. But then later on, after I do some editing on the sheet then run the sub, Excel close again by itself.
To be honest, when I write the code - I myself feel that the code is "merry go round", too many if or maybe too many loop or maybe too long syntax. Would someone please tell me what is wrong with the code ?
I've been thinking to change the code by using findnext to find how many occurence of the looped value in column-A and then have it as cnt variable. But still I'm curious what's wrong with the sub which cause Excel close by itself.
Any kind of respond would be greatly appreciated.
Thank you in advanced.
There are around 150 tables in my Word file. Each table has six rows and two columns.
I need to copy the first and last row values from each table to an Excel sheet.
The first row will have my table id and last row data is Pass/Fail.
In general, you should try to post the code that you tried so far so we can help you debug and get to the final answer:
Summarize the problem
Describe what you’ve tried
Show some code
When appropriate, share the minimum amount of code others need to reproduce your problem (also called a minimum, reproducible example)
But, I'll try to give you some code to get going.
If it helps you, please consider to mark it as the correct answer :)
Please try the following code:
Sub extract_word_table_values_to_excel()
Dim word_app As Object, temp_doc As Object, word_doc As Object
'Set word_app = CreateObject("Word.Application")
ActiveSheet.Calculate
word_path = Range("Word_path")
'Place your word doc path here in the named range on the sheet
temp = Split(word_path, "\")
word_name = temp(UBound(temp))
Set word_doc = GetObject(word_path)
Set word_app = word_doc.Application
word_app.Visible = True
word_doc.Activate
excel_row = 1
On Error Resume Next
Dim word_table As Word.Table 'Or As variant
For Each word_table In word_doc.Tables
Err.Clear
For i = 1 To word_table.Rows.Count Step word_table.Rows.Count - 1
'Step count minus 1 means only first and last row are looped
For j = 1 To word_table.Columns.Count
part = word_table.Rows(i).Cells(j).Range.Text
part = Left(part, Len(part) - 1)
part = Replace(part, vbNewLine, "")
'MsgBox part
Sheet2.Cells(excel_row, j).Value = part
Next j
excel_row = excel_row + 1
Next i
excel_row = excel_row + 1 'Leave row between tables
Next word_table
MsgBox "done"
word_doc.Save
'word_app.Quit
Set word_doc = Nothing
Set word_app = Nothing
End Sub
Please leave a comment if you have a question.
This question already has answers here:
Excel VBA Run-time error '13': Type mismatch
(1 answer)
Error handling in VBA - on error resume next
(3 answers)
Closed 4 years ago.
I have a question about my code to hide rows, when the rows contain some certain key words, as the worksheet is activated.
By testing, my code runs well and I didn't have any errors.
However, it seems that my code is rather vulnerable. Some of the colleagues have often the error reports, if they insert rows or delete rows, which causes the formula reference errors, because I use the “if” formula to produce the “key words”.
What I don’t understand is why this can cause error type 13: type mismatch… and the row "If InStr(1, LCase(MainString), LCase(SubString)) <> 0 Then..." is marked. I read the explanation of Microsoft, but still not understand what type is mismatched here and what I can do to prevent this error.
Thanks a lot for your time and your suggestion in advance!
Screenshots of my rows in the table and error reporting:
Code:
Private Sub Worksheet_Activate()
Dim i As Integer
Dim lastrow As Integer
Dim MainString As String
Dim SubString As String
Application.ScreenUpdating = False
Call unhidden
lastrow = ActiveSheet.Range("A150").End(xlUp).Row
SubString = "risiko benannt"
For i = 9 To lastrow
MainString = Range("B" & i)
If Cells(i, 7).Value > 3 Then
Cells(i, 18).Value = "Ja"
End If
If InStr(1, LCase(MainString), LCase(SubString)) <> 0 Then
Rows(i).EntireRow.Hidden = True
End If
Next i
Application.ScreenUpdating = True
End Sub
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 7 years ago.
Improve this question
New to vba. Just starting to learn. I want to pull some specific data from a website.Code I am trying to modify is from Ron Retrieving specific data from website through excel.
Now this code work on a single url. I have urls in Column A of excel sheet and I want to macro to go one by one to all urls and paste results in Column B C D respectively.
Tried as best as my limited knowledge.
Regards
The main sub will get the ratings and the number of reviews for each URL in column A and will place them in Column B and C. I hope this help you a little.
Sub main()
Dim l As Long
l = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To l
test Range("A" & i)
Next
End Sub
Sub test(URL As Range)
my_url = URL.Value
Set html_doc = CreateObject("htmlfile")
Set xml_obj = CreateObject("MSXML2.XMLHTTP")
xml_obj.Open "GET", my_url, False
xml_obj.send
html_doc.body.innerhtml = xml_obj.responseText
Set xml_obj = Nothing
Set Results = html_doc.body.getElementsByTagName("i")
For Each itm In Results
If InStr(1, itm.outerhtml, "star-img", vbTextCompare) > 0 Then
numb_stars = itm.getAttribute("title")
Exit For
Else
End If
Next
Set Results = html_doc.body.getElementsByTagName("span")
For Each itm In Results
If InStr(1, itm.outerhtml, "reviewCount", vbTextCompare) > 0 Then
numb_rev = itm.innertext
Exit For
Else
End If
Next
URL.Offset(0, 1) = numb_stars
URL.Offset(0, 2) = numb_rev
End Sub
Preview of my output:
Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub