Quantcast
Channel: Excel Help Forum - Excel Programming / VBA / Macros
Viewing all 49888 articles
Browse latest View live
↧

byref argument type mismatch error in function

December 29, 2015, 1:36 am
$
0
0
Hello,

I have this function that changes a sting using another function (scoateA) which is tested and works fine.
When i call this function i get the byref argument type mismatch error and it highlights the line with the function name.

So here it is:
Code:
Function SirNou( hval As String) As String
Dim nrCar As Integer
Dim finVal As String
nrCar = Len(hval) - Len(Replace(hval, ";", ""))
 If nrCar = 0 Then
  SirNou = hval
 Else
  For i = 1 To nrCar
  finVal = finVal & scoateA(hval, i)
  Next i
 SirNou = finVal
 End If
End Function
Any ideas?
↧
Search

Vba code to populate next open alternate rows from userform

December 29, 2015, 2:07 am
$
0
0
Hi All

I have submitted code that I have been trying to figure out for days with no luck.
I have had variations of results but still none that meets the required result.

My worksheets gets populated from a user form and I require the following:
If Option Cheque is chosen from ComboBox2 then the first green row must be populated i.e. Row 3
Thereafter each alternate green row must be populated i.e Row 5, 7, 9 etc
If Option Cash is chosen from ComboBox2 then the first yellow row must be populated i.e. Row 4
Thereafter each alternate yellow row must be populated i.e. Row 6, 8 ,10 etc

Take note: Row 50 is a row containing formulas for totals Row 3 - 49.

I thank you in advance for your expertise.

Code:
Private Sub Populate_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Sheets(ComboBox1.Value)

Sheets(ComboBox1.Value).Activate
   
   
    If Me.ComboBox2.Value = "Cheque" Then
    irow = ws.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
    With ws
    .Range("A" & irow) = Box1.Value
    .Range("B" & irow) = Box2.Value
    .Range("C" & irow) = Box3.Value
    .Range("I" & irow) = Box4.Value
    .Range("J" & irow) = Box5.Value
    .Range("K" & irow) = Box6.Value
    .Range("L" & irow) = Box7.Value
    .Range("M" & irow) = Box8.Value
    .Range("N" & irow) = Box9.Value
    End With
  Else
   
  If Me.ComboBox2.Value = "Cash" Then
  irow = ws.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row + 1
    With ws
    .Range("A" & irow) = Box1.Value
    .Range("B" & irow) = Box2.Value
    .Range("C" & irow) = Box3.Value
    .Range("I" & irow) = Box4.Value
    .Range("J" & irow) = Box5.Value
    .Range("K" & irow) = Box6.Value
    .Range("L" & irow) = Box7.Value
    .Range("M" & irow) = Box8.Value
    .Range("N" & irow) = Box9.Value
  End With
  End If
  End If

Box1.Value = ""
Box2.Value = ""
Box3.Value = ""
Box4.Value = ""
Box5.Value = ""
Box6.Value = ""
Box7.Value = ""
Box8.Value = ""
Box9.Value = ""

ActiveWorkbook.Save
Application.Quit

End Sub
↧
↧

File for shift Schedule

December 29, 2015, 2:18 am
$
0
0
Hi All,

I am looking for a file that can help me with shift schedule. We usually have 2 shift (Night shift from 6:00pm to 7:30am and day shift from 7am to 6:30pm there is always a 30 minutes handing over minutes). Among the shifts there are always 4 or 5 groups i.e. Group A to Group E. Now, am looking for an exlcel file that can help me schedule the staff and also calculate hours worked.

Thanks
↧

Loop excel files and sort it in a tree diagram

December 29, 2015, 3:10 am
$
0
0
Hye, I need help to solve my problem here. I got a situation where there are 3 file in a folder and i want it to tell the user which one first and sort it it a tree diagram. The macro will open the file and see if the number stated inside the file. For example the output macro in the jpg image i stated below.

Hope you guys can help me. Thank you.

Regards,
Afandi.

Here i attach the example 3 file.
Attached Images
Attached Files
↧

Trouble Ending IF Statment in VBA

December 29, 2015, 3:41 am
$
0
0
Hi Experts,

I have managed to put code together and now want to comine two seprate functioning sets of code on the opening of the sheet and require park of the code to run on the IF Statement.

The if statement for the second half of the code is to run if

Code:
If Worksheets("Auto Assign Control").Range("A6").Value = "X" Then
but when I use this I get a End or Block error, presumably becuase I only have half in IF statement. working on the principle that if A6 = "X" then run the code but the bit i dont get is if the statment is false then do nothing.

Any help or pointers would be great

Thanks

Danny

Original Code
Code:
Private Sub Workbook_Open()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("TCLI").Range("A1:M76").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
              vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
 
    End With
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "danhardy@thatslogistics.uk"
        .CC = "ijazmushtaq@thatslogistics.uk"
        .Bcc = ""
        .Subject = "BOWRat - Opened"
        .HTMLBody = RangetoHTML(rng)
        .send
    End With
    On Error GoTo 0
   
        With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With   

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
New Code
Code:
Private Sub Workbook_Open()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("TCLI").Range("A1:M76").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
              vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
 
    End With
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "danhardy@thatslogistics.uk"
        .CC = "ijazmushtaq@thatslogistics.uk"
        .Bcc = ""
        .Subject = "BOWRat - Opened"
        .HTMLBody = RangetoHTML(rng)
        .send  'or use .Display
    End With
    On Error GoTo 0
   
        With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
   
    If Worksheets("Auto Assign Control").Range("A6").Value = "X" Then
   
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        Worksheets("Email Schedule").Activate
    On Error Resume Next
    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngEntry As Range
    Dim rngEntries As Range
    Dim sMsgBody As String
    Dim i As Long

    Set objOutlook = CreateObject("Outlook.Application")
    Set rngEntries = ActiveSheet.Range("C3:C102")

    For Each rngEntry In rngEntries

        If rngEntry.Value = "" Then GoTo Skip
        If rngEntry.Value = "0" Then GoTo Skip

        Set objMail = objOutlook.CreateItem(0)
        With objMail
                .To = rngEntry.Value
            .Subject = "Confirmed Working Pattern for NEXT WEEK"

            '----------------------------------------------------------------
            sMsgBody = rngEntry.Offset(, -1).Value & "," & vbCr & vbCr
           
            sMsgBody = sMsgBody & "Please see your days you have agreed to supply services for next week listed below as" & vbCr
            sMsgBody = sMsgBody & "you requested." & vbCr
            sMsgBody = sMsgBody & "" & vbCr
           
            For i = 1 To 7
                sMsgBody = sMsgBody & rngEntry.Offset(, i).Value & vbCr
            Next i
           
            sMsgBody = sMsgBody & "" & vbCr
            sMsgBody = sMsgBody & "We " & vbCr
            sMsgBody = sMsgBody & "week " & vbCr
            sMsgBody = sMsgBody & "" & vbCr
            sMsgBody = sMsgBody & "Thanks" & vbCr
            sMsgBody = sMsgBody & "" & vbCr
            sMsgBody = sMsgBody & "Administration" & vbCr
            '----------------------------------------------------------------

            .Body = sMsgBody
            .send
           
    End If
   
        End With
 
Skip:
    Next rngEntry

    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngEntry = Nothing
    Set rngEntries = Nothing
   
            End With
   
    With Application
    .EnableEvents = True
    .ScreenUpdating = True
    Worksheets("Route Allocation").Activate
      End With
   

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
↧
↧

Deleting few columns based on a criteria

December 29, 2015, 3:53 am
$
0
0
Dear All,

Good Evening!!!

My below requirement might confuse you, so request you to please go through the attached excel Where I have done changes for the first brand name in the before sheet & after sheet

Its just about deleting content/rows when my requirement meets criteria.

I prepared a format in such a way that one brand has several models for calculating their order, opening stock, Quantity received etc

I want to delete entire row for every brand where Remarks has Quantity received as per order & Ordered Quantity, Opening Stock, Quantity Received & Quantity to be received = zero

I want rows to remain after deleting = max number of rows it occupied under the item shown below

ex: for KEDBROOKE Brand, I've max number of items are 2, So I want to delete next entire rows with remaining 2 rows without deleting

I just also want to delete content (not rows) in the rows that are remain after deleting where where Remarks has Quantity received as per order & Ordered Quantity, Opening Stock, Quantity Received & Quantity to be received = zero

ex: for KEDBROOKE Brand, I've max number of items are 2, So if I have Remarks has Quantity received as per order & Ordered Quantity, Opening Stock, Quantity Received & Quantity to be received = zero with in these 2 rows

DOWNROD/SHACKLE:
CANOPY
ROTOR:
SHAFT:
CAPACITOR:/MAKE
STATOR:
Lamination
BLADE:
MOTOR BOX:
THERMOCOLE TRAY:
STAY CAP / CENTRE PAD:
BEARING
SHOW CAP/ RING
MASTER CARTON:

I hope I didnt confuse you & Request you to please help.
Attached Files
↧

Print Button that removes columns before printing from custom pivot table filter

December 29, 2015, 8:17 pm
$
0
0
Hi All,

I have a dashboard that pulls from a sql database, we use filters to select what data the user would like to see, they select a company/companies and dates that they want to pull data for. Currently we have a print button that takes the custom data requested, formats it, and launches the print set-up.

What i am trying to do is have the print button remove specific columns so that i can change the print from landscape to portrait. There is unnecessary data that does not need to be printed causing clutter and forcing us to print landscape.(it is how ever valuable for internal clients to see, but not external)

Currently the code selects a range for the column and rows (as the amount of rows can change depending on user selection), so i am not sure how complicated it would be to do this.

Anyone have any ideas?

Your help is much appreciated
↧

Recording a long formula not working

December 29, 2015, 10:16 pm
$
0
0
Hi All

I am trying to record a long formula in a column AE, this consist of lots of if and vlookups. Cell A2

When recording the macro, it creates 3 lines of code.

When I try to run the macro I get

Run time 1004.

I know the code needs to be on 1 line to work.
Attached Files
↧
Search

ListBox to write value to another sheet

December 29, 2015, 10:43 pm
$
0
0
Hi there.

I have a list box on sheet1. The name of the second sheet is located on sheet1 in cell K2. K2 will be update often.

Is it possible to have a list box write its value to the sheet named in K2 cell A7?

So, when I link the ListBox to a cell and select an item, a number will be written there. I am trying to have that number written to the sheet named in K2 cell a7. Something like... (K2!A7) except K2 would be replaced with the text value that is in K2.

Thanks
↧
↧

TEXT BOX to appear only if it has text in it

December 29, 2015, 11:47 pm
$
0
0
hello friends,

attached is a SAMPLE document. what is require is that when text is inserted in SHEET1 (B6), SHEET2 should show the same text in a TEXT BOX but the TEXT BOX outline should appear showing it as a BOX. if no text is inserted in SHEET1 (B6 is blank), then SHEET2 should NOT show the outline of the TEXT BOX. FYI, i use SHEET1 as a data sheet where all the data is inserted and the SHEET2 is used as the final output sheet and this sheet is password protected so that one cannot edit.

hope to hear from you and thank you for same.

"WISHING EVERY ONE A JOYFUL AND PROSPEROUS NEW YEAR 2016!""

regards
rizviSample.xlsx
↧

Bad Coding - Run-Time Error '7' Out Of Memory

December 30, 2015, 12:05 am
$
0
0
Hi,

I am having trouble with my coding as below. My Code work fine but when I select all cell, I get the Run-Time Error '7' Out of Memory message. Can anyone help me clean up my code to avoid that? I am a beginner so please make provide simple explanation if possible. Thank you.


Dim lastvalue

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If ActiveSheet.Name <> "Log" Then
Application.EnableEvents = False
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Now
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Cells(Target.Row, 1)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Cells(Target.Row, 2)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Target.Value
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).Value = lastvalue
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = ActiveSheet.Name & "-" & Target.Address(0, 0)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = Environ("username")
Application.EnableEvents = True
End If

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
lastvalue = Target.Value
End Sub

Error 7.jpg
↧

merge cells when command button clicked

December 30, 2015, 12:14 am
$
0
0
Hi, I have this worksheet for data entry. There are 2 command button for transferring userform data to sheet. What I hope to achieve is when user clicks the weekly maintenance button, column C to K of that particular row will merge and display "N.A".
Attached Files
↧

small report to be made fromj two raw data files

December 30, 2015, 12:22 am
$
0
0
Hi Friends,

I have a very small workbook which consists of 3 worksheets. The data of two worksheets have to come out in 3rd worksheet. Format is given in 3rd and data flow is also mentioned there. Please help me urgent. Thanks in advance.
Attached Files
↧
↧

Stopping userform initialise procedure on result

December 30, 2015, 12:29 am
$
0
0
Hi all,

Bit hard to describe in the title, so here goes. I have a spreadsheet for collecting snooker game scores. I am trying to take out the user-interference by only letting the user enter the scores via a userform. Then, when they have entered the next result in the blank fields on the userform, it updates the correct spreadsheet row/column. But I am having a problem getting the cursor to land in the next blank field on the userform.

With my current worksheet, there are entries in cells M4 and N4. These show up fine on the user form related fields TextBox31 and TextBox32. But the cursor them drops into TextBox35, completely skipping past the blank TextBox33 and TextBox34. Can someone point me to where it's going wrong please? I really want the cursor to stop on the next blank field (TextBox33).
All the tab stops are correctly numbered, aligned and whatever :)

Code:
       
Private Sub UserForm_Initialize()

        Me.TextBox1 = Sheets("Games").Range("L4")
        Me.TextBox2 = Sheets("Games").Range("L5")
        Me.TextBox3 = Sheets("Games").Range("L6")
        Me.TextBox4 = Sheets("Games").Range("L8")
        Me.TextBox5 = Sheets("Games").Range("L9")
        Me.TextBox6 = Sheets("Games").Range("L10")
        Me.TextBox7 = Sheets("Games").Range("L12")
        Me.TextBox8 = Sheets("Games").Range("L13")
        Me.TextBox9 = Sheets("Games").Range("L14")
        Me.TextBox10 = Sheets("Games").Range("L16")
        Me.TextBox11 = Sheets("Games").Range("L17")
        Me.TextBox12 = Sheets("Games").Range("L18")
        Me.TextBox13 = Sheets("Games").Range("L20")
        Me.TextBox14 = Sheets("Games").Range("L21")
        Me.TextBox15 = Sheets("Games").Range("L22")
       
        Me.TextBox16 = Sheets("Games").Range("O4")
        Me.TextBox17 = Sheets("Games").Range("O5")
        Me.TextBox18 = Sheets("Games").Range("O6")
        Me.TextBox19 = Sheets("Games").Range("O8")
        Me.TextBox20 = Sheets("Games").Range("O9")
        Me.TextBox21 = Sheets("Games").Range("O10")
        Me.TextBox22 = Sheets("Games").Range("O12")
        Me.TextBox23 = Sheets("Games").Range("O13")
        Me.TextBox24 = Sheets("Games").Range("O14")
        Me.TextBox25 = Sheets("Games").Range("O16")
        Me.TextBox26 = Sheets("Games").Range("O17")
        Me.TextBox27 = Sheets("Games").Range("O18")
        Me.TextBox28 = Sheets("Games").Range("O20")
        Me.TextBox29 = Sheets("Games").Range("O21")
        Me.TextBox30 = Sheets("Games").Range("O22")
       
        Me.TextBox31 = Sheets("Games").Range("M4")
        Me.TextBox32 = Sheets("Games").Range("N4")
        Me.TextBox33 = Sheets("Games").Range("M5")
        Me.TextBox34 = Sheets("Games").Range("N5")
        Me.TextBox35 = Sheets("Games").Range("M6")
        Me.TextBox36 = Sheets("Games").Range("N6")
       
        If IsNull(Me.TextBox31) Or Me.TextBox31 = "" Then
                Exit Sub
        Else
                SendKeys vbTab
        End If
       
        If IsNull(Me.TextBox32) Or Me.TextBox32 = "" Then
                Exit Sub
        Else
                SendKeys vbTab
        End If
       
        If IsNull(Me.TextBox33) Or Me.TextBox33 = "" Then
                Exit Sub
        Else
                SendKeys vbTab
        End If
       
        If IsNull(Me.TextBox34) Or Me.TextBox34 = "" Then
                Exit Sub
        Else
                SendKeys vbTab
        End If
       
        If IsNull(Me.TextBox35) Or Me.TextBox35 = "" Then
                Exit Sub
        Else
                SendKeys vbTab
        End If
       
        If IsNull(Me.TextBox36) Or Me.TextBox36 = "" Then
                Exit Sub
        Else
                SendKeys vbTab
        End If
       
End Sub
Thanks in anticipation
Pete
↧

Copy Major Units value from graph

December 30, 2015, 12:53 am
$
0
0
Hi,

Hoping someone can help. I am new to Excel so would appreciate if anyone can help me write a macro or script for the following. I am using Excel 2016.

I have a spreadsheet with three tabs:

Tab1 is called 'CalculatedValues' and contains numerous data values - some that are referenced in graphs in the rest of the spreadsheet
Tab2 is called 'Graph1' and contains a line graph of data from the tab called 'CalculatedValues'
Tab3 is called 'Graph2' and contains a line graph of data from the tab called 'CalculatedValues'

I want a macro that can do the following. This is something that I will run very often as data inputs change frequently. I may also have far more than 2 graphs in the future.


When I right click on the axis of the graph (numbers on left side of graph) in the tab called 'Graph1', and select 'Format Axis', I want to copy the value in the Major Units box (i.e. 200) and then paste this in cell A1 in tab called 'CalculatedValues'. I then want to do the same for the major axis value from the graph in the tab called 'Graph2' but paste the value in cell A2 in the tab called 'CalculatedValues'.

Grateful if someone can help me with a macro or VBA script to do this. This is for a very good cause. Please note that I am not a programmer so please be gentle:)

Thank you so much
↧
Search

Checking the result of a forumula

December 30, 2015, 1:42 am
$
0
0
How would one go about checking the result of a worksheet formula with VBA?

I have a sheet that uses the MIN function to check the first entry date and the MAX function to check the last entry date on the sheet. Of course, if there is no entries yet, the cell with the function populates with "1/0/1900". That is not horrible, but I like to tidy things up like that and in the process of writing some VBA to do all of the work, I wanted to try and see if I could clean that up.

My thought was to have VBA check the MIN function and if it was returning "1/0/1900" then populate the cell with something along the lines of "No Entries". I am currently using =IF(Register[Date]="","No Entries",MIN(Register[Date])) which of course works. However, I wanted to use VBA (not only to see if I can do so but just to learn more too) to check if the MIN function returns anything (specifically 1/0/1900) and if that is true then populate the cell with "No Entries", else run the MIN function.

Hopefully I explained that well enough. If that can be done, how would one go about doing so?
↧

lookup for the last entry with the criteria..

December 30, 2015, 2:40 am
$
0
0
hello, i have several columns, importantly 3 columns. (i.e. 1. Reference No. 2. Calegories 3. value.) and have 3 categories (i.e. 1. sales, 2. Purchase, 3. Production), i am trying to view the last Reference No.value which contains the criteria "sales" or "Purchase" or "Production".
as example: if if i open sales userform then formm should initialize me.txtRefNo.Value = last sales ref no + 1
Ref. No.__Categories___Value
_1_______Sales________1000
_2_______Sales________2500
_3_______Sales________1500
_1_______Production____2500
_2_______Production____1500
_3_______Production____400
_4_______Production____600
_1_______Purchase_____2000
_2_______Purchase_____3000
what i need is, if i open sales userform then formm should initialize me.txtRefNo.Value = "4" (i.e. last sales ref no
was "3" then now should show +1).
need code regarding the same.. please help me..
thanks in advance..
↧
↧

Delete the last number if the number format is *.***

December 30, 2015, 2:49 am
$
0
0
Hello everyone and happy new year.....


I have a problem that breaks my brain for a lot of days now.

I have this data on my excel file in "A" Column:

UD Maracena vs Guadix 27/12/2015 12:45
2.666
3.20
2.45
(+97) Atletico Sanluqueno CF vs Coria CF 27/12/2015 13:00
1.75
3.50
4.20
(+95) CD Ronda vs Atletico Mancha Real 27/12/2015 13:00
4.333
3.80
1.666
(+96) CD San Roque de Cadiz vs CD herena 27/12/2015 13:00
2.00
3.40
3.40

Before I convert my data with a big macro, I want to delete the last number of every cell that is in format "0.000" I want to make it like this: "0.00" and change it to "General" format and keep the dot "."

So:
1: Delete the last number of every cell that is "*.***" and make it "*.**"
2: Change the format of those cells to "General"
3: Keep the dot (because every time I change those cells to general format, I lose the dot)

I use excel 2013.
This is my test file: dot.xlsm

Please help me with that, thanks everyone and I wish the best for 2016...
↧

How to consolidate data fast?

December 30, 2015, 2:57 am
$
0
0
Hello everyone!

I am looking for a way to consolidate data faster. My script works fine but it takes unfortunately very long. So I wonder if someone can give me some advice on how to make it work faster. My program is rather big with lots of modules so I rather describe what it does and only post the important code.

Background Information:
The goal of my program is to create a standardized looking diagram that shows stock data. I have raw data of about 260.000 rows and 31 columns (Sheet “raw_data”). The raw data consists of stock data like product type, product group, location name, location country, year, quantity, value etc. On another sheet called “Analysis” the user can set filters and select data for the y- and x-axis (i.e. quantity of a certain product in a particular location from 2012-2015).

How does my program work?
The user selects filters and the autofilter is applied to the raw data. After that, the none hidden rows and columns for the y-axis of the diagram are copied to new sheet called “temp”.

Example: Column “location country” is filter for “Italy” and “value” is selected as data type. Finally the y-axis is selected to show the product groups. That means that three columns are copied to a new sheet called “temp” (1. Product groups, 2. Value, 3. Year).

What is described before works fine and rather quickly. So here is where it starts:

For creating a diagram I need to consolidate the data that was selected and copied to the sheet "temp".

Product group Value Year
... ... ...
... ... ...

The result should looks like this:

Product Group 2012 2013 2014 2015
A * * * *
B * * * *
*sum of values

I use the sumifs function to consolidate the data. See my code extract here:

Code:
Sub Consolidate_data()

Dim Column_A_end As Long

Application.ScreenUpdating = False
Application.EnableEvents = False

    With Worksheets("temp")
        Column_A_end = .Range("A1000000").End(xlUp).Row
        .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown)).Copy Destination:=.Range("D1")
        .Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
        .Range("A1:C1").Copy Destination:=.Range("D1")
        .Range("E1") = years(1)
        .Range("E1:K1").DataSeries Rowcol:=xlRows, Type:=xlLinear, Date:=xlDay, step:=1, Trend:=False 'Years 2009-2015
        .Columns("A:F").AutoFit
        .Range("E2").FormulaR1C1 = "=SUMIFS(R2C2:R" & Column_A_end & "C2,R2C1:R" & Column_A_end & "C1,""=""&RC4,R2C3:R" & Column_A_end & "C3,""=""&R1C)"
        If .Range("D1").End(xlDown).Row > 2 Then
            .Range("E2").AutoFill Destination:=.Range("E2:E" & .Range("D1").End(xlDown).Row), Type:=xlFillDefault
            .Range("E2:E" & .Range("D1").End(xlDown).Row).AutoFill Destination:=.Range("E2:K" & .Range("D1").End(xlDown).Row), Type:=xlFillDefault
        ElseIf .Range("D1").End(xlDown).Row = 2 Then
            .Range("E2").AutoFill Destination:=.Range("E2:K2"), Type:=xlFillDefault
        End If
        .Calculate
        .Columns("E:K").Copy
        .Range("E1").PasteSpecial Paste:=xlPasteValues
        .Columns("A:C").Delete
    End With

Worksheets("temp").Range("1:1").NumberFormat = "@"
Worksheets("temp").Columns("A:Z").AutoFit
           
End Sub
Sometimes I have data of more than 100.000 rows to be consolidated which can last > 10 min on my machine. Any idea how to make it faster? I appreciate any advice.

Thank you in advance.

Jack
↧

Macro to compare not working optimal.

December 30, 2015, 3:19 am
$
0
0
Hi I have below macro, which have to do following.

It need to compare the invoices and amount in sheet Advice
with invoices and amount in sheet Sapproposal

But it dont give me the correct result and i am sure can be done another way.

Now it mark the ones with yellow which dont have the correct amount. And the Invoices missing with red.

so when i get the final result special the investigate sheet.

Wanted result is like below

Know which invoices are not in the sheet Sapproposal but in sheet Advice
and also which invoices in sheet Sapproposal are there but have another amount in Sheet Advice

Result will come in 2 sheets Balance and Investigate

Balance is the ones just matching with amount and invoices

Investigate are the one not have the same amount or are not there at all.




Its more easy to see i think in the attached test sheet.
If some could help would be great.

Here is the 2 codes i am using now. But sure it can be done different.

Plese have a look

Sincerely

Abjac

P.s I should maybe say,. I think the error and the not correct result comes because many amounts can be the same. So it need to compare both the amount and invoice together, Which together will be unique.


Code:
Option Explicit
Sub CheckA1()

Dim lr As Long, I As Long, M As String, s As String
    ' M = Application.InputBox(Prompt:="Which column in Sheet2 ?")
    M = "a"
    s = "a"
Application.ScreenUpdating = 0

With Worksheets("Advice")
    lr = .Range(M & Rows.Count).End(xlUp).Row

    For I = lr To 2 Step -1

        If IsNumeric(Application.Match(.Range(M & I).Value, Sheets("Sapproposed").Columns(s), 0)) Then
       
        Else
        ' .Rows(i).Interior.ColorIndex = 6
        .Range(M & I).Interior.ColorIndex = 3
       
       
        End If
    Next I
End With
Application.ScreenUpdating = True
Call CheckA2


End Sub

Sub CheckA2()

Dim lr As Long, I As Long, M As String, s As String
' M = Application.InputBox(Prompt:="Which column in Sheet2 ?")
    M = "d"
    s = "g"
Application.ScreenUpdating = 0

With Worksheets("Advice")
    lr = .Range(M & Rows.Count).End(xlUp).Row

    For I = lr To 2 Step -1

        If IsNumeric(Application.Match(.Range(M & I).Value, Sheets("Sapproposed").Columns(s), 0)) Then
        .Rows(I).Copy Sheets("Balance").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Else
        ' .Rows(i).Interior.ColorIndex = 6
        .Range(M & I).Interior.ColorIndex = 6
        .Rows(I).Copy Sheets("Investigate").Range("A" & Rows.Count).End(xlUp).Offset(1)
       
        End If
    Next I
End With
Application.ScreenUpdating = True

 MsgBox "Macro are finish. The result are in Sheet4 and sheet5"
    Sheets("Investigate").Select
End Sub
Attached Files
↧
Viewing all 49888 articles
Browse latest View live
Search