So I am writing a script to compare two excel files.
I'm using a For loop in the first workbook to get the references I want to find in the second workbook (6450 rows long so that no For loop, way to slow)
I have been looking for some way to use the VLOOKUP thing but i could not make it work Here is the code :
For i = 7 to numLines ''numLines is the number of used lines of the first workbook
If '''test to get out of the LOOP
objExcel.Workbooks(Str1).Sheets(1).Range("D"&i)="" AND objExcel.Workbooks(Str1).Sheets(1).Range("H"&i)="" AND objExcel.Workbooks(Str1).Sheets(1).Range("L"&i)="" Then
i = numLines
Else '' here i get the reference (the 6 first digits of the first workbook and I try to find it in the second)
If objExcel.Workbooks(Str1).Sheets(1).Range("D"&i)<>"" Then
Reference = Mid(objExcel.Workbooks(Str1).Sheets(1).Range("D"&i),1,6)
Set table_lookup = objExcel.Workbooks(Str1).Sheets(1).Range( "C1:C" & numLines2 )
cell = objExcel.Workbooks(Str2).WorksheetFunction.vlookup(Reference, table_lookup, 0, False)
MsgBox cell.row
MsgBox cell.column
End If
End If
Next
You have to switch to the "find" method instead of the vlookup that does not seem to work on vba
For i = 7 to numLines
If objExcel.Workbooks(Str1).Sheets(1).Range("D"&i)="" AND objExcel.Workbooks(Str1).Sheets(1).Range("H"&i)="" AND objExcel.Workbooks(Str1).Sheets(1).Range("L"&i)="" Then
i = numLines
Else
If objExcel.Workbooks(Str1).Sheets(1).Range("D"&i)<>"" Then
Reference = Mid(objExcel.Workbooks(Str1).Sheets(1).Range("D"&i),1,6)
Set r = objExcel.Workbooks(Str2).Sheets(1).Range( "C1:C" & numLines2 )
Set matched = r.Find(Reference)
If Not r.Find(Reference) Is Nothing Then
objExcel.Workbooks(Str1).Sheets(1).Range("R"&i).Value = matched.Offset(0,0).Value
objExcel.Workbooks(Str1).Sheets(1).Range("S"&i).Value = matched.Offset(0,1).Value
objExcel.Workbooks(Str1).Sheets(1).Range("T"&i).Value = matched.Offset(0,2).Value
objExcel.Workbooks(Str1).Sheets(1).Range("U"&i).Value = matched.Offset(0,3).Value
objExcel.Workbooks(Str1).Sheets(1).Range("V"&i).Value = matched.Offset(0,6).Value
End If
End If
End If
Next
Related
I'm trying to CopyPicture cells in Column B, and name them the value in Column 1. I have code that works, except it keeps giving the pictures the wrong names. The baffling thing is that sometimes it works perfectly, and other times it does not.
I have tried to cobble together a routine based on posted examples of the CopyPicture command. I'm pasting it in below.
Yes, I'm a newbie at VBScript. Be gentle. ;-)
Sub makepic()
Dim path As String
path = "C:\BP\BP2020\JPGs\"
Dim CLen As Integer
Dim cntr As Integer
cntr = 1
Dim rgExp As Range
Dim CCntr As String
CString2 = "A1:A6"
Set rgExp2 = Range(CString2)
CString = "B1:B6"
Set rgExp = Range(CString)
For I = 1 To rgExp.Cells.Count Step 1
CCntr = rgExp2.Cells(I).Value
rgExp.Cells.Cells(I).Font.Size = 72
rgExp.Cells.Cells(I).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
rgExp.Cells.Cells(I).Font.Size = 14
''' Create an empty chart with exact size of range copied
CLen = Len(rgExp.Cells.Cells(I).Value)
CWidth = CLen * 85
With ActiveSheet.ChartObjects.Add(Left:=1600, Top:=rgExp.Top, _
Width:=CWidth, Height:=50)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
If CCntr <> "" Then
ActiveChart.Paste
Selection.Name = "pastedPic"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export (path + CCntr & ".jpg")
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
End If
cntr = cntr + 1
Next
End Sub
Again, I expect -- for example -- a picture of the contents of cell B1 to have the name of the contents of A1. I tried making the range A1:B4 (for example), but that got me 8 pictures. I finally decided to try to make 2 ranges, but that didn't work either.
I'm writing a macro that pulls data from one workbook and places it into another. I think I have the code pretty much right except for an error I'm getting in one of my loops:
"Runtime error 9: Subscript out of range"
Here is the code:
Sub PullFromRunsheetsTest2()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim file As Variant, a As String, columnItertor As Integer, path As String
path = "C:\Users\msala\Desktop\Runsheets\"
file = Dir(path & "Runsheet*")
Do Until file = "" ''looking at the first file and loops until the last one
columnIterator = 0 ''setting this as the first set of 8 numbers - will shift the next set of numbers down 8 so they don't overwrite themselves
rowIterator = 0
Do Until rowIterator = 7
a = Workbooks(file).Worksheets("Pacman Runsheet").Cells(7, (2 + rowIterator)).Value '' Set "a" = whatever value is in B7, and iterate through that row
''^^^^(THIS IS WHERE I'M GETTING THE ERROR)
ActiveSheet.Cells(5 + rowIterator + columnIterator * 8, 1).Value = a ''take that value and put it in this column, iterate through.
rowIterator = rowIterator + 1
Loop
columnIterator = columnIterator + 1 ''(ignore this for now)
file = Dir()
Loop
End Sub
From what I've read it seems like there's some sort of problem with maybe the data type of a? Not entirely sure what that might be though. Am I accidentally declaring a as an array somewhere?
I need to reformat a XML file to .CSV.
I already opened the XML in Excel and did a little formating but now I really need to write a macro to get the data into shape. I already started bu I really have issues with the loop logic.
the List has a couple thousand Articles with a variable amount of subarticles.
each subarticle as a the same amount of properties but not every article has the same properties.
https://picload.org/image/ipialic/now.jpg
https://picload.org/image/ipialip/then.jpg
My Code up till now looks like this:
Option Explicit
Dim rowCount As Long, articleCount As Long, propertyCount As Integer, name As String
Sub Sortfunction()
rowCount = 1
articleCount = 0
propertyCount = 0
Do While Sheets("Test").Cells(rowCount, 1).Value <> "end"
If Cells(rowCount, 1).Value = "Reference" Then
rowCount = rowCount + 1
Do While Cells(rowCount, 3).Value = ""
If Cells(rowCount, 3).Value = "4" Then
End If
articleCount = articleCount + 1
Loop
articleCount = articleCount + 1
End If
rowCount = rowCount + 1
Loop
Sheets("result").Cells(1, 1).Value = rowCount
Sheets("result").Cells(2, 1).Value = articleCount
End Sub
At the end of the document i wrote the "end" to have a hook to stop the loop.
Can anyone provide some help? I'm really not the best programmer :-/
I'd really appreciate any help I can get :-)
here he's a translation into algorithm and some tips on functions
update: it was more tricky than I thought... I had to rewrite the code.
The main problem is "how to decide when change column".
I choose this solution "Each product in reference must have the same amount of properties".
If it's not the case, please indicate "how you decide when you have to create a new Column" (you can explain it in plain words)
Here the code rewrited. I tried it on your exemple, it work
Public Sub test()
' Set the range to navigate in your first sheet
Dim cell As Range: Set cell = Sheets("Feuil1").Range("A1")
' set the range to navigate in your result sheet
Dim res As Range: Set res = Nothing
' pos will be used to know the position of a product
Dim lastProperties As Range, posProperties As Range
' While the cell value is not "end"
Do While cell <> "end"
' if the cell is a reference
If cell = "Reference" Then
' Set the range of res
If res Is Nothing Then
Set res = Sheets("Feuil2").Range("A1")
Else
Set res = Sheets("Feuil2").Range("A" & lastProperties.offset(2).Row)
End If
' I set Offset(2) so you will have an empty line between 2 references
' Set the text of the new reference in the result
res = cell.offset(, 1) ' The reference is the cell 1 offset the right of the cell "Reference"
' WARNING : here no writing of titles anymore. It'll be done in the "Else".
' Here you just write "new reference" and reinit var
Else
' Here we have a property
' If the property alreay exist, consider it a new product in the reference
' When we are on a new property, the column of the product if the next to the right
If GetProperties(cell.offset(, 3), res, posProperties) Then
Set lastProperties = posProperties
End If
posProperties = cell.offset(, 4)
End If
' BIG FORGET: you have to get the next cell
Set cell = cell.offset(1)
Loop
End Sub
And the function to search / create your properties
Private Function GetProperties(ByVal propValues As String, ByVal start As Range, ByRef position As Range) As Boolean
Set position = start.offset(1)
' Is the cell below the properties ? Return the row below
' Search for the first "empty row" on the line
If position = propValues Then
Do
Set position = position.offset(, 1)
Loop While Trim(position) <> ""
' Indicate it's an existing value
GetProperties = True
Exit Function
End If
' Is the range empty ?
If Trim(position) = "" Then
' Create the new properties
position = propValues
Set position = position.offset(, 1)
GetProperties = False
Exit Function
End If
' Search the properties in the row below
GetProperties = GetProperties(propValues, position, position)
End Function
It should do the work. If you have any question on understanding some part, don't hesitate
if you don't know about Offset, some reading : https://msdn.microsoft.com/en-us/library/office/ff840060.aspx
I have been trying to get this VBA script to work to automate a task, but I cannot get it to work.
Basically, I have a big task list in excel with multiple columns and over 1000 Rows. It contains the task, who it is assigned to, and if it is open or closed.
In column H is who it assigned to and column N is whether the task is opened or closed.
I am trying to search by last name and if it is OPEN to add one to the counter. The end goal is to get a total count of how many open tasks a person has. Also, some of the cells in column N (task status) has extra text like comments, etc. I am sure that a InStr Function to search for the one word within the Cell would work better, but I cannot figure it out...
here is my code
Sub statuscount()
Dim tasksheet As Worksheet
Dim simons_count As Integer
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" And tasksheet.Cells(x, 14) = "OPEN" Then
simons_count = simons_count + 1
End If
Next x
tasksheet.Range("$O$5").Value = simons_count
End Sub
Thanks for the help!
Using If/And gets tricky in VBA, you're better off nesting two if statements:
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" Then
If InStr(tasksheet.Cells(x, 14).Value, "OPEN") > 0 Then
simons_count = simons_count + 1
End If
End If
Next x
This is a more general function. Insert a module and past the below code in it. Than you can use the function just like any other Excel built-in function
Function LastNamecounter(lastName As String, status As String) As Long
LastNamecounter = 0
Dim tasksheet As Worksheet
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To lr
If InStr(tasksheet.Cells(i, 8).Value, lastName) <> 0 And InStr(tasksheet.Cells(i, 14).Value, status) <> 0 Then
LastNamecounter = LastNamecounter + 1
End If
Next i
End Function
I have the following code below that iterates through rows of a specific range and if a value is present (code not seen), creates copies of the entire pages. My concern is at the bottom of the code in the iteration of r1. It originally only had one conditional statement...
If BiDiRowValid(r1)
and I wanted to add a second conditional statement, which I did...
and Range("MAIN_BIDI_PINMC") <> "No BiDi"
but when I run the code and the MAIN_BIDI_PINMC range = "No BiDi", it errors out and doesn't get past that line. FYI: IsBiDiRowValid() is a function that checks to see that the specific r1 is not empty, and then continues. Right after that subroutine finishes and exits, my code errors with a "Type Mismatch error". I also added the ElseIf line at the bottom, I have not gotten to that code because the top errors out, but I just want to make sure I am writing this iteration correctly, and if anything else needs to be done. Basically, if "NoBiDi" is found in the range, I want it to skip all of this code and go to the next r1... which is what I think I have written... Thanks in advance!
Private Sub start_new()
Dim MC_List As Range
Dim r1 As Range
Dim biDiPinName As Range
Dim Pin As String
Dim mc As String
Dim mType As String
Dim tabName As String
Dim rowNumber As Integer
Dim pinmcSplit() As String
Dim NoBidi As String
On Error GoTo start_biDi_tr_new_Error
Set MC_List = Range("MAIN_PINMC_TABLE")
Set biDiPinName = Range("MAIN_PIN2_NAME")
For Each r1 In MC_List.Rows
If IsBiDiRowValid(r1) And WorksheetFunction.CountIf(Worksheets("MAIN").Range("MAIN_BIDI_PINMC", "No Bidi") = 0 Then
tabName = r1.Cells(1, 8)
pinmcSplit = Split(tabName, "_")
Pin = pinmcSplit(0)
mc = pinmcSplit(1)
mType = r1.Cells(1, 3)
ElseIf WorksheetFunction.CountIf(Worksheets("MAIN").Range("MAIN_BIDI_PINMC"), "No Bidi") = 1 Then
End If
Next
You are getting that error because Range("MAIN_BIDI_PINMC") is not a single cell. To check for a value in multiple cells you can use Application.Worksheetfunction.Countif
EDIT
Post discussion in chat, the user wanted to loop through each cell.
Dim aCell As Range
For Each r1 In MC_List.Rows
If IsBiDiRowValid(r1) Then
For Each aCell In Worksheets("MAIN").Range("MAIN_BIDI_PINMC")
If aCell.Value <> "No Bidi" Then
tabName = r1.Cells(1, 8)
pinmcSplit = Split(tabName, "_")
Pin = pinmcSplit(0)
mc = pinmcSplit(1)
mType = r1.Cells(1, 3)
End If
Next
ElseIf aCell.Value = "No Bidi" Then
'~~> Do Something
End If
Next