I have a large table of sales data with multiple columns of descriptions and then columns for the each of the 12 months. I would like to keep the multiple descriptor columns but combine the monthly data into one column.

I use excel for mac and not a regular user of vba. I know it can be done with formulas like offset but I cant figure it out. Thanks for your help.

Trying to write Selenium script for taking screenshots with specific dimension and saving in a single excel sheet.

Any leads with be appreciated...

I would like the new dates in the market cap to be same as the dates in value, eliminating the other dates in the market cap which are not present in the value. This can be presented in a new column. I have attached a pic showing how it is supposed to match, as in the same dates across the different columns.

enter image description here Please assist in how to proceed with this. Thank you.

I tried some VBA coding too, but it didn't result in any solution. I have attached the picture of the coding I tried. enter image description here

I tried the next code:

Option Explicit 
Sub matchdates()
 Dim finalrow As Long, i As Integer
 Sheet2.Range("A7").Select
 finalrow = Sheet2.Range("A5000").End(xlUp).Row
 For i = 4 To finalrow
     If Range("A7") = Range("E7") Then
         Range(Cells(i, 1), Cells(i, 2)).Copy
         Range(Cells(i, 5), Cells(i, 6)).Copy
         Range("k100").end(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
    End If
 Next i 
End Sub

The dates columns in this sheet does not match. I want the dates in column E to match the dates in column A and show the closing prices of both the VALUES and MARKET CAP. The dates in column E which are not available in column A is to be eliminated. I have attached the screenshot of the sheets, the code I have tried, and the sheet of how the outcome should be. Kindly assist. Thank you.

Option Explicit       
Sub matchdates()      
 Dim finalrow As Long, i As Integer      
 Sheet2.Range("A7").Select       
finalrow = Sheet2.Range("A5000").End(xlUp).Row            
For i = 4 To finalrow               
 If Range("A7") = Range("E7") Then              
     Range(Cells(i, 1), Cells(i, 2)).Copy             
     Range(Cells(i, 5), Cells(i, 6)).Copy          
     Range("k100").end(xlUp).Offset(1, 0).PasteSpecial             
End If          
Next i          
End Sub          

enter image description here

enter image description here

I'm trying to use a macro to import a picture in an excel sheet, but I want the picture to be small compressed. After import I want to be able to click on the picture to expand, and click again to shrink. I've found the following two macros but I'm novice at VBA and am having trouble combining them. Thanks in advance

Sub CompressPicture()
Dim fName As String
Dim pic As Picture
Dim r As Range

fName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
If fName = "False" Then Exit Sub

Set r = ActiveCell
Set pic = Worksheets("Sheet1").Pictures.Insert(fName)

With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left
    .Top = r.Top
    .Width = r.Width
    .Height = r.Height
    .Select
End With

If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

Sub Picture2_Click()
Dim shp As Shape
    Dim big As Single, small As Single
    Dim shpDouH As Double, shpDouOriH As Double
    big = 5
    small = 1
    On Error Resume Next
    Set shp = ActiveSheet.Shapes(Application.Caller)
    With shp
        shpDouH = .Height
        .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
        shpDouOriH = .Height

        If Round(shpDouH / shpDouOriH, 2) = big Then
            .ScaleHeight small, msoTrue, msoScaleFromTopLeft
            .ScaleWidth small, msoTrue, msoScaleFromTopLeft
            .ZOrder msoSendToBack
        Else
            .ScaleHeight big, msoTrue, msoScaleFromTopLeft
            .ScaleWidth big, msoTrue, msoScaleFromTopLeft
            .ZOrder msoBringToFront
        End If
    End With
End Sub

I'm trying to copy and paste some specific row numbers from one excel workbook, but that Excel workbook contains many sheets.

I'm trying to copy Row number 3,4 8,9 and 10 from each workbook, we have 100 excel sheet like this:

But in my final result, I want this as follows

OrganizationName   ProductName    Average_Rating    NUmerofSoldService CurrentUserCount

Apple               iphone          3.43                15                 79

Apple               ipad            4.28                 20                100

Samsung             Galazy          3.182                50                20

and so.. on

Could you please suggest to me how to copy and paste into either a new sheet or workbook?

Hoping someone might have a clue if there is anything I can do to work around the problem I am having. It might be difficult to add the code in I am using as it is so big.

I have a table with calendar dates in the first column. They are all in dd/mm/yyyy format. In VBA I want to search for a date and find the row number within the calendar using the following;

FirstRow = Workbooks(WorkbookSelected.Name).Sheets("Tables").Columns(1).Find(ConfirmedDate, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookAt:=xlWhole).Row

The Confirmed Date is stored as a Date variable, taken from the calendar as well, but it gets days added to it. I am searching in two different workbooks to find the FirstRow. If both workbooks are in the same application/instance of excel then this code works fine.

But if I open the 2nd workbook in a new instance of excel, it errors because the date isn't found. Something is happening with the date in the 2nd application. If I use format(ConfirmedDate, "dd/mm/yyyy") it will find it in the 2nd workbook. But that code won't work in the original workbook. Similar code to above, but just referencing the Excel Instance it needs to look into. I get the Runtime Error 91 when it won't find it.

FirstRow = ExcelInstanceSelected.Workbooks(WorkbookSelected.Name).Sheets("Tables").Columns(1).Find(ConfirmedDate, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookAt:=xlWhole).Row

FirstRow = ExcelInstanceSelected2.Workbooks(2ndWorkbookSelected.Name).Sheets("Tables").Columns(1).Find(ConfirmedDate, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookAt:=xlWhole).Row

I am trying to find a way to find the date in the calendar regardless of which excel application I am using. I have tried opening the workbook with the local set to true (doesn't help). I have tried combinations of format, cdate, cdbl, lookin:=xlformulas. Nothing will work with both workbooks.

It is driving me nuts. I can only assume that the .find in the 2nd workbook is changing the format of the stored ConfirmedDate to the US format of m/dd/yyyy. I just can't find a way to ensure both dates can be formatted to dd/mm/yyyy regards of how they start.

Many thanks for any help.

Cel

I need all your Excel VBA expert to help.

The following code is working but I have a few following questions 1) If I have more than 1 email address in Outlook and would like to specific email address in Excel . Let say in tab, cell is for me to type email address. How can I specific it in the following code

2) If I have to specific a folder (not default folder--inbox,sent,draft, delete) and would like to specific in folder name in Excel Let say in , cell is for me to type folder name. How can I specific it in the following code

Thanks in advance

from bnfkru ========================================

Sub GetFromInbox()

    Dim olApp As Outlook.Application
    Dim olNs As Namespace
    Dim Fldr As MAPIFolder
    Dim olMail As Variant
    Dim i, ij As Integer
    Dim tt As Date

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
    i = 1
    ij = 0
    x = Date

    ' Now. the following "For each next " code starts to look in the oldest email!
    ' So how can I change the code if the code starts from the newest?
    For Each olMail In Fldr.Items
        ij = ij + 1
        'If IsNumeric((Format(olMail.ReceivedTime, "dd/mm/yy"))) Then
            Sheets("test").Range("a1").Select
            Sheets("test").Range("I1").Clear
            Sheets("test").Range("I2") = ij
            Sheets("test").Range("I1").Value = (Format(olMail.ReceivedTime, "dd/mm/yy"))
            Sheets("test").Range("I1").NumberFormat = "dd/mm/yy"
            tt = Sheets("test").Range("I1")
            ' MsgBox ("Y-tt="& tt & " receivedtime="& olMail.ReceivedTime)
        'Else
            'tt = 0
            'MsgBox ("N-tt="& tt & " receivedtime="& olMail.ReceivedTime)
        'End If
        ' tt = CDate(Format(olMail.ReceivedTime, "dd/mm/yy"))
        If tt >= Range("H1") Then
            'If InStr(olMail.Subject, "others") > 0 And tt >= Range("h1") Then
            If InStr(olMail.Subject, "others") > 0 Then
                ActiveSheet.Range("h2") = "y"
                ActiveSheet.Cells(i, 1).Value = olMail.Subject
                ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
                ActiveSheet.Cells(i, 3).Value = olMail.SenderName
                tt = CDate(Format(olMail.ReceivedTime, "dd/mm/yy"))
                ActiveSheet.Cells(i, 4).Value = CDate(Format(olMail.ReceivedTime, "dd/mm/yy"))
                ' tt = ActiveSheet.Cells(i, 4).Value
                ActiveSheet.Cells(i, 5).Value = (Format(olMail.ReceivedTime, "hh:mm"))
                MsgBox ("tt="& tt)
                i = i + 1
            End If
        Else
            Sheets("test").Range("h2") = "N"
        End If
    Next olMail

    Set Fldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
    'tt = ""

End Sub

So I have entered data into separate tabs, but kept in order of survey. ex - Joe Smith's survey answers are in column a on tab 1 and tab 2.

The question on tab 1 concerns type of health coverage (1,2,F), two questions on tab 2 relate to the price and quality of coverage rated 1-5.

I only want to capture the answers for tab 2 questions from people who responded to having coverage. How can I do this?

So I have tried the following, but I am getting a syntax error but I feel like this is looking at the range vs comparing cells

=COUNTIFS(B9:WB9, "1", [B9:WB9, "2"],[B9:WB9, "3"],[B9:WB9, "4"],[B9:WB9, "5"],['page 2'!B16:GW16, "1"])

Basically if 'page 2'!B16 equals 1, 2, or F I want the number in B9 counted, then move to 'page 2'!C16 and so on

I can use countif to get the totals of responses to 1,2,F (I already have these) but I need the sum of corresponding answers. But can I use Countif as a condition to grab the value of another cell's variables and then get a sum of of those values?

I want to write multiple dataframes, either pandas, or koalas, or pyspark in one excel sheet and do something fancy like xlwx does(changing size or color of cells, etc), and save in an S3 bucket. I've tried pandas.to_csv(s3.....test.xlsx) but that is not what I want.

I am trying to add a blank row if the cell values under column C is "Confirm". Is this possible? I want the macro to add blank rows below until the last active row of the sheet if it finds "Confirm" under column C.

regards, Arjun T A

I have a spreadsheet with 250+ rows of data and need to find the largest value in each row. I tried to use Conditional Formatting, however I need the same rule for each row so can't highlight all the data, and trying to copy and paste it would be too cumbersome.

Is there a faster way of applying the same rule to each row separately?

I have a scenario where I want to search data on the basis of column number "C"

Below is my code

Option Explicit

Private Sub TextBox1_Change()
Me.TextBox1 = Format(StrConv(Me.TextBox1, vbUpperCase))

Dim sh As Worksheet
Set sh = Sheets("Sheet2")

Dim i As Long
Dim x As Long
Dim p As Long

Me.ListBox1.Clear

'Display Header

Me.ListBox1.AddItem "Product Name"
Me.ListBox1.List(ListBox1.ListCount - 1, 1) = "HSN Code"
Me.ListBox1.List(ListBox1.ListCount - 1, 2) = "Quantity"
Me.ListBox1.List(ListBox1.ListCount - 1, 3) = "Rate"
Me.ListBox1.List(ListBox1.ListCount - 1, 4) = "GST"
Me.ListBox1.List(ListBox1.ListCount - 1, 5) = "Total"

Me.ListBox1.Selected(0) = True

For i = 2 To sh.Range("B"& Rows.Count).End(xlUp).Row
For x = 1 To Len(sh.Cells(i, 2))
p = Me.TextBox1.TextLength

If UCase(Mid(sh.Cells(i, 2), x, p)) = Me.TextBox1 And Me.TextBox1 <> "" Then

With ListBox1

.AddItem sh.Cells(i, 2)
.List(ListBox1.ListCount - 1, 1) = sh.Cells(i, 3)
.List(ListBox1.ListCount - 1, 2) = sh.Cells(i, 4)
.List(ListBox1.ListCount - 1, 3) = sh.Cells(i, 5)
.List(ListBox1.ListCount - 1, 4) = sh.Cells(i, 6)
.List(ListBox1.ListCount - 1, 5) = sh.Cells(i, 7)
End With

End If
Next x
Next i

End Sub

On basis of First Column "B" The result are displayed I want to search on the basis of Column "C"

Excel sheet2 Data:

When I enter in text Box HSN1 the Data should be displayed in Listbox and Not on basis of AB..

My output : When I enter HSN2 in Textbox

Output:

I have a scenario where i want to populate unique values into combobox excluding duplicate values

My sheet details

Code :

Private Sub ComboBoxscname_DropButtonClick()
    With Worksheets("A1")
                ComboBoxscname.List = .Range("B2:B"& .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With
End Sub

I have highlighted with yellow which are duplicated for column "B" it should be displayed only once in combobox

Another solution i have but getting error when selecting specific sheet name

Sub ComboBoxscnameList()

Dim LR As Long
Dim ctrl As Object
'Set ctrl = Sheets("A1").Select

LR = Cells(Rows.Count, "B").End(xlUp).Row

ctrl.List() = CreateArray(Range("B2:B"& LR))

End Sub

'creates an array from a given range
'ignores blanks and duplicates

Function CreateArray(r As Range)
    Dim col As New Collection, c As Range, TempArray(), i As Long

    'for each cell in range r
    For Each c In r
        On Error Resume Next
        col.Add c.Value, CStr(c.Value)
        If Err.Number = 0 And Trim(c) <> "" Then
            ReDim Preserve TempArray(i)
            TempArray(i) = c.Value
            i = i + 1
        End If
        Err.Clear
    Next

    CreateArray = TempArray
    Erase TempArray

End Function

Private Sub ComboBoxscname_DropButtonClick()
Call ComboBoxscnameList            
End Sub

I am trying to consider only the least few in an array of some X number's, i am getting #NUM! error when the function cannot find the length specified.

Example- Small(range,{1,2,3}) here the range of cells that contain numeric value is "range" and {1,2,3} is the 3 smallest number to be considered, what happens if the range has only 2 digits instead of 10.

Any advises will be helpful. I was expecting a solution where the number can be made adjusted from the numerics available.

Here is the best example i can give

I previously asked a question regarding how to change font of matching items from an array on Sheet2. Now I want to go a little further and return the matching quantities to Sheet1 that matches the red fonted items. I really want to use vba to become more familiar and learn.

Here is my code below:

Dim i, j, x As Integer
Dim box1, box2, box3, box4, box5, box6, box7, box8, box9 As String
Dim c As Range 'Define two ranges so that we can loop through both sheets to check the boxes
Dim d As Range
Sheets(1).Range("B11:B30, F11:F30").Font.ColorIndex = 0 'Remove the cell styles to apply new ones
box1 = Sheets(1).Cells.Range("C2")
box2 = Sheets(1).Cells.Range("C4")
box3 = Sheets(1).Cells.Range("C6")
box4 = Sheets(1).Cells.Range("F2")
box5 = Sheets(1).Cells.Range("F4")
box6 = Sheets(1).Cells.Range("F6")
box7 = Sheets(1).Cells.Range("I2")
box8 = Sheets(1).Cells.Range("I4")
box9 = Sheets(1).Cells.Range("I6")
Qty = Sheets(1).Cells.Range("D10")

'This refers to the checkbox
For i = 1 To 10 'Loop to find the checked box in sheet2

    'box 1 items and quantites
    If Sheets(2).Cells(1, i) = box1 And Qty Then 'Check for checked box
        For Each c In Sheets(2).Range(Sheets(2).Cells(2, i), Sheets(2).Cells(6, i))

            If Sheets(2).Range(Sheets(2).Cells(2, i), Sheets(2).Cells(6, i)) = Sheets(1).Range("D11:D30").Value And Sheets(2).Range(Sheets(2).Cells(2, i), Sheets(2).Cells(6, i)) <> "" Then
                x = x
                Else
                x = x + 1
            End If

            For Each d In Sheets(1).Range("B11:B30, F11:F30")
                If c = d Then
                    Sheets(1).Cells(d.Row, d.Column).Font.ColorIndex = 3 'changes matching item to red font
                End If
            Next d
        Next c

Please note I'm just working on returning the quantities for box 1 so far. That's why I haven't posted the full code. Please see picture for better understanding of my lists I'm pulling from:Box Lists

I have the following html:

<div class="                        product-price
">                
                <span   itemprop="price" content="3.99" class="price-value-11442">
                    3,99€
                </span>

I copied to notepad++ and it displays 5 tabs and 4 spaces. How to get the innertext of span? The following is not working, it shows nothing:

    Set price = ie.Document.querySelector(".product-price .price")
    wks.Cells(i, "C").Value = price.innerText

Trying to use a barcode scanner to automatically search a spreadsheet and check it off (routine verifications of assets).

I recorded the macro and it searches a specific string then changes the cell color to "check it off".

How can I make it wait for input from the scanner then search that input instead? I want the "IT2000" to be a variable that changes based on the barcode scanner.

Recored Macro:

Sub Macro1()
'' Macro1 Macro
'' Keyboard Shortcut: Ctrl+b
'
    Sheets("S15-137").Select
    Cells.Find(What:="IT2000", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Selection.Style = "Good"
End Sub

My goal is to extract all email addresses from the Word.ActiveDocument and put them into one single cell in the Excel Sheet.

The code is run from Excel VBA editor. It needs to search for email addresses, extract them from the document and fill the Excel cell Activesheet.Range("C31"). Only one cell is available, no matter how many email addresses have been found.

The addresses found need to be delimited using ", " the coma and the space.

I'm trying to do this by finding @ in the document and then building up the range forward and backwards to have all the email address in the range variable. Building the address to the right was quite easy using rng.MoveEndUntil Cset:="," because in my document there is always a coma after the email address.

But how to get the missing left side of the email address into the range variable?? I've used rng.MoveStart Unit:=wdWord, Count:=-1 but what if the email will be romek.zjelonek@wp.com or grawer.best@yahoo.com It will not work.

This is what I have now.

Sub FindEmail035()         '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
                           '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim ExcelApp As Excel.Application

Dim rng As Word.Range
Dim emailAdr As String
Dim ws As Worksheet

Set WordApp = GetObject(, "Word.Application")
Set ExcelApp = GetObject(, "Excel.Application")
Set WordDoc = WordApp.ActiveDocument
Set rng = WordApp.ActiveDocument.Content
Set ws = ExcelApp.ActiveSheet

ExcelApp.Application.Visible = True

    With rng.Find
        .Text = "@"
        .Wrap = wdFindAsk
        .Forward = True
        .MatchWildcards = False
        .Execute

        Debug.Print rng.Text
        If .Found = True Then
            'rng.Expand (wdWord)
            'Debug.Print rng.Text
            rng.MoveStart Unit:=wdWord, Count:=-1
            Debug.Print rng.Text
            rng.MoveEndUntil Cset:=","'rng.MoveEnd Unit:=wdWord, Count:=1
            'rng.MoveEndUntil Cset:="", Count:=wdBackward
        End If
   End With     'how to create loop that will extract all the email addresses in the document??
   ws.Range("C31").Value = rng

End Sub

What loop should I use to get the number of mails present in the document and later build up the ranges with email addresses inside?

This is the place in the document where the mail addresses reside.

I'm using the following query to email a workbook using VBA, I'm struggling on how to delete all the queries in the new temp file that will be emailed out, any pointers or suggestions will be really appreciated.

I've came across the following bit of code which i tried adding in after savecopyas but no joy and unsure how to change it from ThisWorkbook to the tempfile

Dim pq As Object
For Each pq In ThisWorkbook.Queries
    pq.Delete
Next

The code I'm using is as follows:

Sub Test()
    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim FileExt As String
    Dim TempFileName As String
    Dim FileFullPath As String
    Dim MyWb As Workbook
    Dim MyWs As Worksheet
    Dim emailRng As Range, cl As Range
    Dim sTo As String

    Set MyWb = ThisWorkbook
    Set MyWs = MyWb.Sheets("Menu")

    Set emailRng = MyWs.Range("O1:O50")
    Set StartDate = MyWs.Range("B9")
    Set EndDate = MyWs.Range("B12")

    For Each cl In emailRng
        sTo = sTo & ";"& cl.Value
    Next

    sTo = Mid(sTo, 2)

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    TempFilePath = Environ$("temp") & "\"

    FileExt = "."& LCase(Right(MyWb.Name, Len(MyWb.Name) - InStrRev(MyWb.Name, ".", , 1)))

    TempFileName = "Utilisation & Waiting List Report "& Format(Now, "dd-mmm-yy")

    FileFullPath = TempFilePath & TempFileName & FileExt

    MyWb.SaveCopyAs FileFullPath

    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)

    strbody = "Hi All,"& vbNewLine & vbNewLine & _
              "Utilisation & Waiting List Report "& StartDate & " to "& EndDate & vbNewLine & vbNewLine & _
              "Please see attached future Utilisation for PAC, Theatre and POC Clinics for CAT and PAC and Theatre clinics for YAG along with Waiting List Figures."& vbNewLine & vbNewLine & _
              "Thanks,"& vbNewLine & _
              "SpaMedica Business Analysts"

    On Error Resume Next
    With NewMail
        .To = sTo
        .CC = ""
        .BCC = ""
        .Subject = "Utilisation Report & Waiting List "& Format(Now, "dd-mmm-yy")
        .Body = strbody
        .Attachments.Add FileFullPath '
        .Send   
    End With
    On Error GoTo 0

    Kill FileFullPath

    Set NewMail = Nothing
    Set OlApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub