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

color alternating rows

January 25, 2020, 5:14 am
$
0
0
Hi to all,
this macro color alternate rows if column A is not empty.
Is it possible to modify "or even the B / C column" ?

Code:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim bClr As Boolean
  Dim c As Range, rChanged As Range
  Dim cols As Long
 
  Const sRange As String = "A2:H500"
 
  Set rChanged = Intersect(Target, Range(sRange).Columns(1))
  If Not rChanged Is Nothing Then
    Application.ScreenUpdating = False
    With Range(sRange)
      .Interior.ColorIndex = xlNone
      cols = .Columns.Count
    End With
    For Each c In Range(sRange).Columns(1).Cells
      If c.Value <> vbNullString Then
        If bClr Then
          c.Resize(, cols).Interior.ColorIndex = 15
        End If
        bClr = Not bClr
      End If
    Next c
    Application.ScreenUpdating = True
  End If
  End Sub
thank you
xam
↧
Search

Copying text from clipboard to first empty row

January 25, 2020, 6:44 am
$
0
0
I have a 30 line text file with all lines looking like this, some separated by empty lines. All have a 'return' (CR LF) at the end.

Code:
GPX file name = tFileName = 20190706Cadgwith-Coverack-r1060-m7.3.gpx         
Track description = tTrackDescr = Cadgwith to Coverack, SWCP 2019

Date for later use =  tDatePrefix = 20190706
I have externally copied all the text to the clipboard. My VBA macro includes this code which display it in a temporary message box. (Well, most of it. Apparently there is a 1024 character limit.)

Code:
Sub Test_GetData()
    Dim objData As New MSForms.DataObject
    Dim strText

    objData.GetFromClipboard
    strText = objData.GetText()

    MsgBox strText
End Sub
But I'm struggling with the next two stages and would appreciate some help please.

1. For each line, set a VBA variable containing the part after last equal sign. Ideally, but not essential, I'd like to use a variable name identical to the string after the first equal sign. So the first line would generate a string variable called 'tFileName' with value '20190706Cadgwith-Coverack-r1060-m7.3.gpx'.

2. In the single, already open workbook 'WalkIndex.xlsm', sheet 'Target', create a new row from these variables at the end of all previous rows. So tFilename would be entered into col C, tDatePrefix into col B, etc. When my source was in another workbook I was doing it with the following code (developed with much help here):

Code:
Sub CopyCellsToWI_ToEmpty_BigEdit()
'Copy cells from a another workbook to WalkIndex.xlsm, sheet 'Target'
'====================================================================

'Set up most variables/objects
Dim nr As Long, wi As Workbook, wb As Workbook, ws As Worksheet
Set wi = Workbooks("WalkIndex.xlsm")
Set ws = wi.Sheets("Target")

'Find the first empty row (col A) in WalkIndex
    With ws
    'Find first empty row (last used + 1)
    nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
 
    'Copy track data to appropriate cells of WalkIndex in first empty row
   
    'Track date copied to two locations in WalkIndex: col A & col B
    'Copy to 'Date of walk' (col A)
    wb.Worksheets("Track Data").Range("B6").Copy ws.Range("A" & nr)
       
    'Copy to 'Date prefix' (col B)
    wb.Worksheets("Track Data").Range("B6").Copy ws.Range("B" & nr)

    'Duration (hhmm)
    wb.Worksheets("Track Data").Range("B10").Copy ws.Range("J" & nr)
   
    etc
   
    End With
etc
End Sub

I've attached an extract from WalkIndex.xlsm

Any assistance would be much appreciated please.
Attached Files
↧
↧

Multiple condition in regex

January 25, 2020, 7:09 am
$
0
0
I want to part of full name with Bachelor academic
For example in col b
Dr.ir. Alex,Msc col C dr.ir col d =Alex col e = msc
In my code has sucsess if any sign after bachelor to col c,d,e
Ir.alex or ir alex
Or ir. Alex
But my problem
If name follwed by bachelor in back of name
H.alex,Ir is sucses if after name is (,)
But failed
If Ir.Alex wiliam Msc
Or ir.Alex wiliam Phd
Result col c ir col d = name and col e
Phd

Code:

makro nya
Sub test()
Dim ar(), i&, ii&, a, temp As String, RE As Object: Set RE = CreateObject("vbscript.Regexp")
a = Columns(2).SpecialCells(2).Value: Columns("c:f").ClearContents
ReDim ar(1 To UBound(a) + 1, 1 To 4)
 
RE.Global = True: RE.ignoreCase = True: RE.MultiLine = True
RE.Pattern = "(.*?(?=,)),?(.*)" 'regex ke 1 split koma pertama jumpa alias titel belakang
    For i = 2 To UBound(a)
      If RE.test(a(i, 1)) Then
        ar(i - 1, 4) = RE.Replace(a(i, 1), "$1") 'nama
        ar(i - 1, 3) = RE.Replace(a(i, 1), "$2") 'koma kebelakang
      Else
          ar(i - 1, 4) = a(i, 1)
      End If
    Next i
        'regex ke 2 untuk ambil nama titel depan atau tanpa titel
        RE.Pattern = "(.*\b(ir|prof|hj|h|d(rs|rg|r|ra|rh))\b)?(?:\.)?(.+)"
    For i = 1 To UBound(ar)
          ar(i, 1) = RE.Replace(ar(i, 4), "$1") 'titel depan
          ar(i, 2) = RE.Replace(ar(i, 4), "$4") 'nama
    Next i
[c1].Resize(, 3).Value = Array("Nama", "Titel Depan", "Titel Belakang")
[c2].Resize(UBound(ar, 1), UBound(ar, 2) - 1).Value = ar
End Sub
↧

Automate Data Values into Text Boxes in real time

January 25, 2020, 2:05 pm
$
0
0
Hi,

I created a graph for my company.

I make this for my personal company once a month.

The problem is ITS SO MANUAL.

1. To get to the point E34:F41 will become the new values in text box in the rows 44:48 (right now it's overlaying the graph - DIRECT AND SUPPORT RATIOS)

2. Additionally, each quarter (Q4,Q1, Q2, Q3, Q4, Q1) has respective "Direct and Support" numbers which essentially in the increase or decrease for a specific team which is calculated in cells D3:O13.

2(cont). These values I take and very, very manually fill the blue text (i.e +25 will be +9 represnting 359 vs 368 and all the "+" under is will change for their new valies, i.e RE +4 will become RE+5) - note all teams are wont be observable in the blue text as new team were just added!

Essentially the graph has text for ALL changes to team #'s and the Direct vs Support texts is then dragged between their respective quarters.

Is there anyway to have automated text boxes that update automatically, even if quarter by quarter since I can always drag it to their places but right now i type EACH ONE and they change ALOT! I'm open to any idea's, if i have to drage 30 of them it's easier than this manual process since numbers can change over and over again!

THANK YOU **FEELING HOPEFUL**
Attached Files
↧

Insert table with non zero values using a userform

January 25, 2020, 2:40 pm
$
0
0
Hi,
I am looking for help creating a VBA userform in my excel workbook which would contain a table displaying select entries from my raw data table that contain corresponding non zero values. Please see the attached table as an example. The userform should display -
Pens 5
Calculators 3
Caps 2
Erasers 6

Thanks!
Attached Files
↧
↧

Need Help on Macro to Copy Shape and Paste into PowerPoint

January 25, 2020, 3:54 pm
$
0
0
Hello Folks

I have got a macro that copies Excel Sheets and pastes onto Powerpoint which works fine, however I have specific sheets which
holds Grouped Shapes (Basically Excel Chart with some Text Boxes) in which case the macro fails.
I have reasonably searched various articles and forums but was not able to resolve.

Appreciate if someone can tweak my code.

Code:
Sub ExporttoPPT()

'variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim Xchart As Excel.ChartObject
Dim xlShape As Object
Dim SlideCount As Long
Dim row As Long

'pp variable = Create a new powerpoint presentation
Set pp = CreateObject("PowerPoint.Application")

'Powerpoint presentation = add the object (the finished product) to the poewrpoint presentation
Set PPPres = pp.Presentations.Add

'powerpoint is now visible
pp.Visible = True

'Hide specific Sheets to generate the Pack

For Each wsname In Array(Sheet1.Name, Sheet2.Name, Sheet3.Name, Sheet41.Name)
    Worksheets(wsname).Visible = False
    Next


'range you pick for selection
MyRange = ActiveSheet.PageSetup.PrintArea

'For each worksheet in the active workbook select all the worksheets and wait however many seconds
For Each xlwksht In ActiveWorkbook.Worksheets
  If xlwksht.Visible = True Then
    xlwksht.Select
    Application.Wait (Now + TimeValue("0:00:1"))
   
    'copy the picture from the range you selected
   
    ' Check if there is a shape in the activesheet
    If ActiveSheet.Shapes.Count > 0 Then
     
    ActiveSheet.Shapes("Group1").Select
   
    'Appearance:=xlScreen, Format:=xlPicture

        Else

   
    MyRange = ActiveSheet.PageSetup.PrintArea
       
    xlwksht.Range(MyRange).CopyPicture _
    Appearance:=xlScreen, Format:=xlPicture
   
    End If

    'Slide count
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
    PPSlide.Select

    'paste the shapes
    PPSlide.Shapes.Paste
    pp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = True
    pp.ActiveWindow.Selection.ShapeRange.Top = 20
    pp.ActiveWindow.Selection.ShapeRange.Left = 20
    pp.ActiveWindow.Selection.ShapeRange.Width = 700
    pp.ActiveWindow.Selection.ShapeRange.Height = 350



End If
Next xlwksht

pp.Activate

 
'Cleans it up
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing


Sheet1.Visible = True
End Sub
↧

[SOLVED] Remove empty entries from combobox list

January 25, 2020, 5:04 pm
$
0
0
Hello,

I have a couple Comboboxes and a Listbox which sources are labeled ranges. These ranges will get data added to them regularly so changing the scope is not a solution.
There are lists with up to 60 cells in the range but most of the time they only contain a few entries, and the combobox/listbox shows a long string of empty spaces at the bottom.
Is there a way to hide empty cells in these menus?
↧

Lottery Lines: Matching values in a table

January 25, 2020, 6:30 pm
$
0
0
Hi everyone,

If I have a table of values with five columns and 20 rows, each row is an individual set with five distinct elements. The possible range of values in each cell is from 1 to 99. I am trying to generate row 21, in such a way as to have unique combination of numbers such that there is no duplicate pairs. For example:

1 2 3 4 5
6 7 8 9 10
...
96 97 98 99 1

For row 21, I want to generate five columns of data, with no duplicate pairs. The next row could be 6 12 18 24 30 (but not 6 2 3 11 16, because the pair 2 3 already exist in the very first row). It feels like a MATCH problem, but I can't work out how to set this up. Sure row 21 is straightforward, but row 121 will not be. I'd like to be able to generate this list without having to pick through it.

Thanks for your help (in advance),

Robin
↧
Search

Adding Conditions to Auto-Sort Macros

January 25, 2020, 7:02 pm
$
0
0
Hello,

I currently have macros that will auto-sort dates in C8:C208. Is it possible to modify the code so that it does not auto-sort until data is also entered in the adjacent D and E cells? So, for example, I would enter the date in C8, enter data in D8, enter data in E8, and then it would auto-sort column C by date.


Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("C:C")) Is Nothing Then
Range("C8").Sort Key1:=Range("C9"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub


Thank you
↧
↧

Help Required on Bank Reconcoliation

January 26, 2020, 12:09 am
$
0
0
dear fellows, i want help on bank reconciliation, where in 1st sheet in put pendinf cheques of last month and in 2nd sheet i put GL and in 3rd sheet i put Bank statement.
In bank statement, aal cheques need to be cleared in Reconciliation or in GL, Pendind entries of debit side of banks statement will be shown in addition side and not checked entries, which are not present in GL, will be shown in Les column..... can i have any macros or programming where all entries been automatically been checked and deleted , because i have large bank satatement and reconciliation to make bank reconciliation easier.... if any one can guide me then i will he thankfull ....
waiting for response plz.
Attached Files
↧

Add border automatically

January 26, 2020, 2:29 am
$
0
0
Hi all, I have tried playing about with Conditional formatting and recording a macro to see code, but just end up baffled, here's what I am trying to achieve,

if cell B10 has data entered into it, i would like the range of cells B10 to J10 to have a bottom edge border appear Automatically, if the data in B10 is cleared then the border on the range of cells also is removed.

i Hope this is clear

many thanks

Scouse13
↧

A macro wich will delete (or hide) rows in one tab under conditions from other tab

January 26, 2020, 4:59 am
$
0
0
Hi guys, as I'm not really familiar with VBA, this is really hard for me to figure out how to write macro.

I already have a macro, which I need to change (or to just have new one), because need to change the process. What I have Is a button, which delete rows with name "invoice" in specific column.

What I need right now (as I needed to make some changes in the tab 1) is a macro which automatically will remove/hide rows from tab 1. The difference now is that I need to follow what is in Column A, Sheet1 - not all invoices must be deleted. Sometimes I would need to delete Black, sometimes Red, and sometimes both. So I was thinking of having combo box instead of a button, but have no clue how to do this. I already made a new list (old was just "invoice" or "non-invoice") and put a combo box. But tried to change macro I already have and did not work.
Attached Files
↧

Cant Figure Out Syntax For Range As A Variable

January 26, 2020, 5:23 am
$
0
0
Hi, Im having a problem with using range variables, basically the CriteriaValue variable refuses to work correctly, & gives errors whenever its called ... Im pretty sure its the syntax, & not sure how to fix it ...

This is a basic countif script, but cant get the main variable to use the countif to work, this is stored in CriteriaValue.

Thanks

Code:
Sub ValleyDips()

Dim ValuesRange As Range
Dim ResultCell As Range
Dim CriteriaValue As Range



Set ValuesRange = Range("A1:A4")
Set ResultCell = Range("C3")

Set CriteriaValue = Range("A1")

HighestCurentValue = Range(CriteriaValue).Value

For j = 1 To 4


    ResultCell = Application.WorksheetFunction.CountIf(ValuesRange, "<" & Range(CriteriaValue))
   
    If ResultCell > 3 Then

        d = ValuesRange.Offset(i, 0).Address
        i = i + 1
        MsgBox d & HighestCurentValue
       
        End If

   
   
    If ResultCell < 3 Then

        d = CriteriaValue.Offset(i, 0).Address
        i = i + 1
        MsgBox d & HighestCurentValue
       
        End If


Next j
End Sub
Attached Files
↧
↧

Creating Outlook Rules via Excel VBA

January 26, 2020, 5:33 am
$
0
0
Hello everybody!

I am currently trying to create a folder and then set up a rule in Outlook via Excel.
While creating the folder works just fine, the code below does not create a rule even though it returns no error. If I go to the Outlook rule manager, then there a no rules.

The rule itself is supposed to move all incoming mails to the newly created folder. The equivalent Outlook rule description is "Apply this rule after the message arrives -> move a copy to the specified folder".

Can anyone help me out here?

Code:
'Create Outlook Folder
Dim OutApp As Object, OutNS As Object, OutMainFolder As Object, OutNewFolder As Object, OutAccount As Object

On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
If Err.Number <> 0 Then 'If Outlook is not installed, next line will generate an error
    MsgBox "Cannot find Outlook on your computer. Cancelling operation!", vbCritical
    GoTo SkipRest
End If
On Error GoTo 0

Set OutNS = OutApp.GetNamespace("MAPI")
Set OutMainFolder = OutNS.GetDefaultFolder(6) 'Inbox folder: 6 = olFolderInbox
Set OutNewFolder = OutMainFolder.Folders.Add("Excel Synch")

'Create rule
Dim OutTargetFolder As Object, OutRules As Object, OutRule As Object, OutMoveRuleAction As Object, OutCondition As Object
Set OutRules = OutApp.Session.DefaultStore.GetRules()
Set OutRule = OutRules.Create("Excel Synch", 0) ' 0 = olRuleReceive
Set OutMoveRuleAction = OutRule.Actions.MoveToFolder
With OutMoveRuleAction
    .Enabled = True
    .Folder = OutNewFolder
End With

OutApp.Session.DefaultStore.GetRules().Save

SkipRest:
End Sub
↧

Offset Alters Entire Range, Need To Offset A Single Cell

January 26, 2020, 6:04 am
$
0
0
Hi, Im trying to offset the range in ValuesRange = Range("A1:A4"), but I need to just offset cell A4, atm it offsets the entire range so it looks like : A2:A5 A3:A6 etc., I just need the A4 part offset, so it looks like A1:A5, A1:A6, A1:A7 etc.,

Is there anyway to do this, without splitting the range into two variables?

Thanks.


Code:
Sub ValleyDips()
    Dim ValuesRange As Range
    Dim ResultCell As Range
    Dim CriteriaValue As Range
    Set ValuesRange = Range("A1:A4")
    Set ResultCell = Range("C3")
    Set CriteriaValue = Range("A1")
    HighestCurentValue = CriteriaValue
    For j = 1 To 4
        ResultCell = Application.WorksheetFunction.CountIf(ValuesRange, "<" & CriteriaValue)
        If ResultCell > 2 Then
            d = ValuesRange.Offset(i, 0).Address
            i = i + 1
            MsgBox d & HighestCurentValue
        End If
        If ResultCell < 2 Then
            d = CriteriaValue.Offset(i, 0).Address
            i = i + 1
            MsgBox d & HighestCurentValue
        End If
       
        'MsgBox d & HighestCurentValue
       
    Next j
End Sub
Attached Files
↧
Search

Inserting row into excel table in protected sheet

January 26, 2020, 7:00 am
$
0
0
Hi,

Edit Mod : this thread is related to https://www.excelforum.com/excel-pro...ml#post5267116

I have an excel table in a protected Excel sheet. I should be able to insert row(s) in the table but it is not possible because the sheet is protected therefore I got warning message ("The cell or chart you're trying to change is on a protected sheet. To make a change, unprotect the sheet. You might be requested to enter a password."). I set AllowInsertingRows:=True but it does not help because this an Excel table. Do you know how I can handle this by macro? I tried using the following macro but not working. Can you please help to implement this in the attached table or find another solution?


#Function IsCellInTable(cell As Range) As Boolean
'PURPOSE: Determine if a cell is within an Excel Table


IsCellInTable = False

On Error Resume Next
IsCellInTable = (cell.ListObject.Name <> "")
On Error GoTo 0

End Function

Private Sub AddTableRows()
'PURPOSE: Add table row based on user's selection


Dim rng As Range
Dim InsertRows As Long
Dim StartRow As Long
Dim InsideTable As Boolean
Dim RowToBottom As Boolean
Dim ReProtect As Boolean
Dim Password As String
Dim area As Range

'Optimize Code
Application.ScreenUpdating = False

'What is the worksheet password?
Password = "Nemzetisport89"

'Set Range Variable
On Error GoTo InvalidSelection
Set rng = Selection
On Error GoTo 0

'Unprotect Worksheet
With ActiveSheet
If .ProtectContents Or .ProtectDrawingObjects Or .ProtectScenarios Then
On Error GoTo InvalidPassword
.Unprotect Password
ReProtect = True
On Error GoTo 0
End If
End With

'Loop Through each Area in Selection
For Each area In rng.Areas

'Is selected Cell within a table?
InsideTable = IsCellInTable(area.Cells(1, 1))

'Is selected cell 1 row under a table?
RowToBottom = IsCellInTable(area.Cells(1, 1).Offset(-1))

'How Many Rows In Selection?
InsertRows = area.Rows.Count

'Selection Not Within Table?
If Not InsideTable And Not RowToBottom Then GoTo InvalidSelection

'Add Rows To Table
If InsideTable Then

'Which Row in Table is selected?
With area.Cells(1, 1)
x = .Row
y = .ListObject.DataBodyRange.Row
Z = .ListObject.DataBodyRange.Rows.Count
End With

StartRow = Z - ((y + Z - 1) - x)

'Insert rows based on how many rows are currently selected
For x = 1 To InsertRows
area.ListObject.ListRows.Add (StartRow)
Next x
ElseIf RowToBottom Then
For x = 1 To InsertRows
area.Cells(1, 1).Offset(-1).ListObject.ListRows.Add AlwaysInsert:=True
Next x
End If

Next area

'Protect Worksheet
If ReProtect = True Then ActiveSheet.Protect Password

Exit Sub

'ERROR HANDLERS
InvalidSelection:
MsgBox "You must select a cell within or directly below an Excel table"
If ReProtect = True Then ActiveSheet.Protect Password
Exit Sub

InvalidPassword:
MsgBox "Failed to unlock password with the following password: " & Password
Exit Sub

End Sub
Attached Files
↧

If cell matches then paste cells on same row

January 26, 2020, 7:41 am
$
0
0
Hiya,

I need the code to be able to do the below. I've had a go but not come anywhere near.

Compare the cells in column 2 in Sheet2 against column 2 in Sheet1. If the contents of the cell matches the copy the cells in O:S on that row in Sheet2 to the corresponding row in Sheet1. If it doesn't match any then copy the whole row from Sheet2 and paste at the bottom of the list in Sheet1. Both lists will be of a variable length.

I hope that make sense. I've attached a sample workbook.

Tim
Attached Files
↧
↧

Using Offset As A Variable Gives Errors

January 26, 2020, 7:41 am
$
0
0
Hi, Not sure why this doesnt work, trying to use offset as a variable - ValuesRangex = ValuesRange.Offset(i, 0).Address, everything else works fine.

Thanks again.


Code:
Sub ValleyDips()
    Dim ValuesRange As Range
    Dim ValuesRangex As Range
   
    Dim ResultCell As Range
    Dim ResultCellMax As Range
   
    Dim CriteriaValue As Range

    Dim ValuesRangeStart As Range
    Dim ValuesRangeEnd As Range
    Dim CurrentCriteriaValue As Range
   
    Set ValuesRange = Range("A1:A3")
    Set ResultCell = Range("C3")
    Set ResultCellMax = Range("C5")
   
    Set CriteriaValue = Range("A1")
    HighestCurentValue = CriteriaValue
   
   
    For j = 1 To 21
   
        ResultCell = Application.WorksheetFunction.CountIf(ValuesRange, "<" & CriteriaValue)
        If ResultCell > 1 Then
        ValuesRangex = ValuesRange.Offset(i, 0).Address
          i = i + 1
          HighestCurentValue = CriteriaValue
            MsgBox ValuesRangex & HighestCurentValue
            ResultCell = Application.WorksheetFunction.CountIf(ValuesRangex, "<" & CriteriaValue)
        End If
       
        If ResultCell < 1 Then
       
        'Check if dip up
       
        CriteriaValue = CriteriaValue.Offset(i, 0).Address
        ResultCellMax = Application.WorksheetFunction.CountIf(ValuesRange, ">" & CriteriaValue)
        End If
       
        If ResultCellMax > 2 Then
          d = ValuesRange.Offset(i, 0).Address
            i = i + 1
            HighestCurentValue = CriteriaValue
            MsgBox d & HighestCurentValue
            ResultCellMax = Application.WorksheetFunction.CountIf(ValuesRange, ">" & CriteriaValue)
        End If
       
        MsgBox "ResultCell" & ResultCell
       
    Next j
End Sub
Attached Files
↧

Delete all rows where column F = 0

January 26, 2020, 10:54 pm
$
0
0
Hi all,

I'd like to delete all rows (entirely) when column F has a value = 0

I tried some past macros from this forum but got "Could not complete operation" error when I tried them.

I've attached my workbook.

I'd appreciate any & all help!

Thanks~
Attached Files
↧

Vlookup other workbook open workbook on background

January 26, 2020, 11:15 pm
$
0
0
For my userforum I make a code with Vlookup to search for data in a other workbook, the code is working perfect. I like to work with different people together in one workbook
Only I have one question, is it possible to open the other workbook on the background, so other users are not deposited during their work.

I use this code:
Code:
Private Sub CmdZoekAddapt_Click()


Dim Search As Variant

Dim book1 As Workbook
Dim extwbk As Workbook
Dim x As Range


Set book1 = ThisWorkbook
Set extwbk = Workbooks.Open("C:\Users\admin\Desktop documenten\aanvragen overzicht.xlsm")
Set x = extwbk.Worksheets("aanvragen").Range("A7:x10000")

Search = txtZoek.Value
If IsNumeric(Search) Then Search = Val(Search)
If IsError(Application.Match(Search, x.Columns(1), 0)) Then
    MsgBox "Nummer niet bekend", vbCritical, Search
    Exit Sub
End If
txtJaar.Text = Application.WorksheetFunction.VLookup(Search, x, 18, False)
TxtMonsternr.Text = Application.WorksheetFunction.VLookup(Search, x, 2, False)
txtVersie.Text = Application.WorksheetFunction.VLookup(Search, x, 3, False)
txtKlant.Text = Application.WorksheetFunction.VLookup(Search, x, 4, False)
TxtVorm.Text = Application.WorksheetFunction.VLookup(Search, x, 5, False)
txtdeeg.Text = Application.WorksheetFunction.VLookup(Search, x, 6, False)
txtvulling.Text = Application.WorksheetFunction.VLookup(Search, x, 7, False)
TxtDecoratieA.Text = Application.WorksheetFunction.VLookup(Search, x, 8, False)
TxtDecoratieB.Text = Application.WorksheetFunction.VLookup(Search, x, 9, False)
txtopmerking.Text = Application.WorksheetFunction.VLookup(Search, x, 10, False)
TxtFoto.Text = Application.WorksheetFunction.VLookup(Search, x, 11, False)
txtaantal.Text = Application.WorksheetFunction.VLookup(Search, x, 12, False)
txtverpakking.Text = Application.WorksheetFunction.VLookup(Search, x, 13, False)

extwbk.Close savechanges:=False

End Sub
↧
Viewing all 49851 articles
Browse latest View live
Search