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

VBA code to input a static date in a cell

May 17, 2016, 3:26 am
$
0
0
Hey Guys,

I currently have the following formula in Column A 1-500

Code:
=IF(E34<>"",IF(A34=" ",TODAY(),A34)," ")
And I have options, Calculations, Iterations set to 1 so everytime I input something in column B todays date auto populates in column A and it does not change each day thanks to the iterations being set at 1. However i recently noticed that there are a few formulas not correctly adding up when I make some changes and when I press save it seems to recalculate correctly. I'm guessing the reason for this is because of the iterations above. If this is correct and makes sense to you then is there a VBA code I could do if I for example "if column B >1 input Date in Column A. Someone previously suggested a DATE code but have no idea how to write it into my existing code (which I got a lot of help writing in the first place) First off would this work and second of all would it stay static or would it change each day?. I need it to stay static. I am not brilliant on VBA so I have attached the current code in a particular sheet and maybe you could show me how to input the new bits around the existing (if it's possible) in the first place.

All suggestions greatly appreciated

Thanks Matt

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Const sPW As String = "$P$2"
Const sHide As String = "I:I, O:O"
If Not Intersect(Target, Range(sPW)) Is Nothing Then
    If Target.Value = 1234 Then
        ActiveSheet.Unprotect
        'Range(sHide & 1).EntireColumn.Hidden = False
        Range(sHide).EntireColumn.Hidden = False
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    ElseIf Target.Value = "" Then
        ActiveSheet.Unprotect
        'Range(sHide & 1).EntireColumn.Hidden = True
        Range(sHide).EntireColumn.Hidden = True
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells
    End If
    End If
   
    Private Sub Workbook_BeforeClose(Cancel As Boolean)
ActiveSheet.Unprotect
        ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    ActiveSheet.EnableSelection = xlUnlockedCells

End Sub
↧
Search

VBA Macro for scroll calendar not working after duplicating a worksheet

May 17, 2016, 11:12 pm
$
0
0
I hoping someone can help me with a VBA issue I am having as I am only a novice.

I downloaded a free leave tracker template online. Part of the template includes a calendar which enables you to scroll back and forth between months. A macro is used to make this work. So far I have been able to customize the template to suit my needs.

However, I want to have two leave trackers in the same workbook. To do this I have simply copied the worksheet. When I now go to use the calendar scroll I get the following error:

Run-time error 1004
METHOD ' RANGE' of 'object'_worksheet' failed.

I believe it has something to do with the fact that one macro is now trying to operate two calendar scrolls. I think the following script must be modified to for the calendar scroll to work.

Sub showcalendar()

LeaveTracker.Columns("B:NI").Hidden = True
LeaveTracker.Range(Columns(Range("A3").Value * 31 - 29), Columns(Range("A3").Value * 31 + 1)).Hidden = False
End Sub


I tried to duplicate the module and rename the sub with another name but this did not work. Can someone please suggest how I can have two worksheets using the same calendar scroll. I.e do I need to create two different modules and assign the module to a particular worksheet?

Thank you
↧
↧

Selecting a range of columns based on a cell value

May 18, 2016, 12:23 am
$
0
0
Good morning.

I am deleting a range of columns once a month using the following as part of a bigger routine


Columns("B:CI").Select
Selection.Delete


The column selction always starts at "B" however the width changes every month.

B:CI =Jan 2016
B:CJ =Feb 2016
B:CK =March 2016

On a seperate worksheet I want to be able to type "CK" in a specific cell and the macro to select columns B:CK, likewise if I typed "DE" in the specified cell the macro would choose columns B:DE

Many thanks
Phil
↧

Clear Column by macro

May 18, 2016, 1:15 am
$
0
0
I need a code to delete specific column without delete the first cell in it ....?!
↧

[SOLVED] match function unable to find the first higher value

May 18, 2016, 1:17 am
$
0
0
dear all ,

first of all sorry but I can no more find option to highlight the code .......

I use the below match function inside a userform that works perfectly if I use the option "0" or "1" .
If I need to match the first higher value I tried using "-1" but I get the error : unable to get match property of the worksheet function class
attchd example workbook....


Private Sub CommandButton1_Click()
Dim var1 As Integer
Dim var2 As Integer
Dim a As Integer
Dim b As Integer

a = TextBox1.Value
b = TextBox2.Value

With Application.WorksheetFunction

var1 = .Match(a, Worksheets("Sheet1").Range("A2:A6"), 1)
var2 = .Match(b, Worksheets("Sheet1").Range("B1:E1"), 1)

TextBox3.Value = .Index(Sheet1.Range("B2:E6"), var1, var2)

End With

End Sub
Attached Files
↧
↧

Clicking on a particular button from http://www.mapdevelopers.com/distance_from_to.php

May 18, 2016, 1:18 am
$
0
0
Hi guys,

I have made a program that will put addresses into http://www.mapdevelopers.com/distance_from_to.php

But I don't know how to get excel to Click on the "calculate distance" button. I've looked on a bunch of youtube videos (which is why I'm able to put values into the 'from' and 'to' boxes. But am still unable to get it to click the button for me). It should be the last lane of code that needs to be changed to something else.


Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")

IE.navigate "http://www.mapdevelopers.com/distance_from_to.php"
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
IE.document.all("from").Value = Addy1.Value
IE.document.all("to").Value = Addy2.Value

IE.document.all("link_button").Click





Any advice would be awesome.



Thanks,

Jimmy
↧

Problem .find method returns nothing

May 18, 2016, 1:34 am
$
0
0
I am trying to find two different string one after the other in a workbook, but the second one returns nothing. Can you tell me why, I assume it's due to "after:=activecell", active cell being in the last column of the range I am looking for?

Code:
Dim emptyrow2 As Long
Dim emptyrow3 As Long
Dim zone As String
Dim zone1 As String
Dim zone2 As String
Dim zone3 As String



Workbooks.Open Filename:= _
        "C:\Users\mciavaldini.TAMOILCY\Desktop\2016 PLANNING.xlsm"


If Mid(CARGO2016.DEL_BEG.Value, 4, 3) <> Mid(CARGO2016.DEL_END.Value, 4, 3) Then

zone = "29-Jun-16"
zone1 = "02-Jul-16"
zone2 = zone2 = Format(WorksheetFunction.EoMonth(CDate(CARGO2016.DEL_BEG.Value), 0), "dd-mmm-yy")
zone3 = Format("01-" & Mid(zone1, 4, 3) & "-" & Right(zone1.Value, 2), "DD-MMM-YY")

If zone1 <> zone3 Then


With ActiveWorkbook

Set zonerow = Cells.Find(What:=zone, After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
       
        zonerow.Activate
       

emptyrow2 = Selection.Find(What:="*", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).row + 1
       

Set zone3row = Cells.Find(What:=zone3, After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
       
        zone3row.Activate
       

emptyrow3 = Selection.Find(What:="*", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).row + 1

 ......

from emptyrow2 the next string to find returns nothing.....Here is the table in which I want to find the strings, the above code is generated from an userform...
Attached Files
↧

Assign Range into Arrray and then use array to find text to make new range and seach word

May 18, 2016, 1:59 am
$
0
0
Hi Guys,

Thanks in advance.

I need a code in below sequence.

1) Assign a Dynamic range in "Proposal Data" worksheet to array.

2) using array, find from array value from "Spec Landing" Worksheet and also find text "Stocks and Inks" below that array vale cell to form new range. now from this new range find "Comment: " Text

3) All the Text after "Comments: " should be copy and paste in worksheet "Proposal Data" Column X again that particular Array


Note :- in Worksheet "Spec Landing" data is saved in Unicode Text in A:A column.

Untitled.png

Untitled1.png


i used the below code but failed.

Dim Rng As Range, rRange As Range
Worksheets("Proposal Data").Active
Dim Ram As Worksheet
Dim Sham As Worksheet
Dim LastRow As Integer
Dim vArray As Variant
'Dim WArray As Variant
Dim i As Long

Set Ram = Worksheets("Proposal Data")
Set Sham = Worksheets("Spec Landing")

LastRow = Ram.Cells(Rows.Count, "Q").End(xlUp).Row
vArray = Ram.Range("Q5:A" & LastRow)

For i = LBound(vArray) To UBound(vArray)

FirstRow = sht.Range("A:A").Find(vArray(i), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastRow = sht.Range("A:A").Find(" Stocks and Inks ", After:=FirstRow, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
xan = sht.Range(FirstRow & LastRow).Select

With xan
Tan = Range(xan).Find(What:="Comments:", After:=FirstRow, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
'
If Not Tan Is Nothing Then
End If
End With
Next

End Sub
↧
Search

how to use MySQL for saving excel report data

May 18, 2016, 2:04 am
$
0
0
Hi All,

I need suggestion/advise/procedure how to use MySQL for storing/retrieving/editing data.

I want to use MySQL to store company reports data in MySQL to get this what are the necessary thing I need to do.

actually I created Timesheet form in Excel which store Employee day production data in excel and I want to store this information in MySQL database.

I Install MySQL for Excel and I got the Icon in Data Tab in excel and when I am trying to Create New Database its getting failed.

could any one please explain what are the things I need to install and what are the necessary things I need to do.

hoping for the solution !

thank you !
Mohammad Naveed.
↧
↧

Index Similar function for returning a value

May 18, 2016, 2:48 am
$
0
0
Dear All,

As we everyone is familiar with Index, Match & Match function which would retrieve the value based on Row value & Column Value.

Similar way, I want to have a User Defined function that would return the value to a cell based on Row & Column values

i.e., Index, Match & Match function will retrieve the value whereas my userdefined function should return a value to a cell based on Row & Column values through a UserForm

UserForm should have 1. Array - Text Box for selecting the array 2. Row - Combo list that must have Unique values based on Row Selected in a sheet 3. Column - Combo list that must have unique values based on Column selected in a sheet 4. Quantity - Text Box that is to enter the quantity which will return a value to a cell based on the above selections 5. 2 Buttons Submit & Clear for returning a valueto a cell & for clearing the above selections respectively.

This UF should not be active always, I somehow should call it.


I've furnished all the details in the attached report and do the needful.
Attached Files
↧

Extract text from string

May 18, 2016, 3:13 am
$
0
0
I have this string of text in B1: "Tennis\Internationaux de Strasbourg 2016\Second Round Matches\K Bondarenko v Vesnina"

In C1, I want to extract "K Bondarenko v Vesnina"

In my head, I'm thinking that I need to find how many characters there are from the start to the 3rd "\" (this is the bit I am struggling with). Then use the 'LEN' function to find out how many characters there are in total. Then minus the first part from the total. Then use this use value to find to determine how many characters to go from the right, using the 'RIGHT' function.
↧

[SOLVED] dictionary problem

May 18, 2016, 3:41 am
$
0
0
Hello everybody!:)

I have a problem with my code when I need to paste the keys of my dictionary (for the range "D2:J43") in a new sheet. In fact the dictionary works for all the number except for one. I mean every single number is copied and pasted except the first occurrence (7). I think it's a problem with the indices but I tried different options and nothing works. I put an example of the file in attachment file in case somebody can have a look at it. Just erase range "C1:G1" sheets.("resu")before using the macro.
Thank you very much and have a good day!

Code:
Option Explicit
Option Base 1
Sub CultureSelect()
Dim i As Integer, j As Integer
Dim cult As Variant
Dim mondico As Object
Dim a As Variant

With Sheets("Typology_w")
      Sheets("typology_w").Activate
            cult = .Range("D2:J43").Value
            For i = 1 To UBound(cult, 1)
                For j = 1 To UBound(cult, 2)
                    ReDim tablo(1 To UBound(cult), 1)
                        ReDim tablo(1 To UBound(cult), 2)
                Next j
            Next i
      Set mondico = CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(tablo, 1)
                For j = 1 To UBound(tablo, 2)
                If cult(i, j) <> "" Then mondico(cult(i, j)) = cult(i, j)
                Next j
            Next i
 With Sheets("resu")
        a = mondico.items
            For i = 1 To UBound(a)
              .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = a(i)
            Next i
   
End With
End With
Attached Files
↧

How to clear content on the cell that has background color from conditional formatting?

May 18, 2016, 3:52 am
$
0
0
Please, help me. I have fill color into cells used conditional formatting. But I can't delete the content using VBA below:
Code:
Sub CCVALUES()

        Range("G1:AK500").Select
        For Each Cell In Selection
        If Cell.Interior.ColorIndex = 15 Then
        Cell.ClearContents
        End If
        Next

End Sub
But if I input the color manually it can finds the color index and clears the content.
↧
↧

How to convert a .txt file to .inc without editing inside data using vba

May 18, 2016, 3:54 am
$
0
0
Hi,
Actually I created a .inc(example: trial1.inc) file using vba , after creating it is not shown in folder. But if I run the code again(example: trial2.inc) and the time when it ask save location I can see previous file there(trial1.inc) . After I finish running code second time(for trial2.inc) both are not there. But If I save myoutput as text(.txt) it showing in respective folder. Thats the reason I want to make .txt file then convert it to .inc . please help
↧

Changing checkbox background color - loop to check all tick boxes on sheet for status TRUE

May 18, 2016, 4:14 am
$
0
0
Hi there

I need to change the background colour for checkboxes on my spreadsheet. I have managed to do this for a single checkbox as follows:

Code:
Private Sub CheckBox1_Click()
 
        If CheckBox1.Value = True Then
            CheckBox1.BackColor = RGB(255, 0, 0)
        Else
            CheckBox1.BackColor = RGB(255, 255, 255)
        End If
   
End Sub
Now, I have well over 100 checkboxes on this sheet (eg sheet7) and was hoping not to have to copy this code that many times to cover all. Would appreciate some help with creating a loop to check for all tick boxes on the sheet and apply the colour change to the checkbox background when it comes across a box that is ticked.

Many thanks in advance...
↧
Search

Creating a Macro to Copy a sheet to several workbooks

May 18, 2016, 4:20 am
$
0
0
Hi,

I am fairly new to the whole Macro scene and need some help please. I am looking for a macro that will copy a sheet from 1 workbook and copy it into several closed workbooks, all saved in the same folder. I have been playing with the below but can't seem to get it to work. Any help greatly appreciated.



Code:
Sub CopySheet()
   
    Const strFldrPath As String = "C:\Workbook Problems\" 'Where the workbooks are all saved
   
    Dim CurrentFile As String, FileExt As String, wb As Workbook, wsActive As Worksheet, ThisExt As String
    Set wsActive = ActiveWorkbook.ActiveSheet
    If InStr(1, ActiveWorkbook.Name, ".", vbTextCompare) > 0 Then
        ThisExt = StrReverse(Left(StrReverse(ActiveWorkbook.Name), InStr(1, StrReverse(ActiveWorkbook.Name), ".", vbTextCompare)))
    Else
        ThisExt = ".xlsx"
    End If
   
    CurrentFile = Dir(strFldrPath)
    While CurrentFile <> vbNullString
        FileExt = StrReverse(Left(StrReverse(CurrentFile), InStr(1, StrReverse(CurrentFile), ".", vbTextCompare)))
        If LCase(ThisExt) = ".xls" Then
            If LCase(FileExt) = ".xls" Or LCase(FileExt) = ".xlsx" Or LCase(FileExt) = ".xlsm" Then
                Set wb = Workbooks.Open(Filename:=strFldrPath & CurrentFile)
                wsActive.Copy Before:=wb.Sheets(1)
                wb.Close True
            End If
        Else
            If LCase(FileExt) = ".xlsx" Or LCase(FileExt) = ".xlsm" Then
                Set wb = Workbooks.Open(Filename:=strFldrPath & CurrentFile)
                wsActive.Copy Before:=wb.Sheets(1)
                wb.Close True
            End If
        End If
        CurrentFile = Dir()
    Wend
   
    ActiveWorkbook.Save
    ActiveWorkbook.Close
 
End Sub
↧

Repeat action to all columns

May 19, 2016, 2:01 am
$
0
0
Dear All...i need to actual clear cell that has #N/A next to it. i'd tried looking up every where but i couldn't find a solution.
Thus, i use another way of approaching by cutting and paste cell contains #N/A to the right cell of it.
However i came to a cross road as it only applies to column A and on the rest of cells that contains #N/A.
Attached is the sample of file which only consists couple of columns. The actual file has 100's of them.
Really need help on this matter.
Thank you.

Code:
Sub test()

Dim r As Range


    Do
        Set r = Columns(1).Find("#N/A")
        If r Is Nothing Then Exit Do
        r.Cut Destination:=r.Offset(0, 1)
    Loop
End Sub
Attached Files
↧
↧

Problem at saving sencond file in a loop "Run time error '9'"

May 19, 2016, 2:24 am
$
0
0
'Hello,

i have written the following code, it opens all the files (100) of a folder and copys the worksheet on a given one

but when it is going to save the second file it gives me:

Run time error '9', subscript out of range.

can you help me?

Code:
Sub OpenFiles()Dim MyFolder As String
Dim MyFile As String
Workbooks.Open Filename:="C:\Users\juan\Desktop\ww\xx.xlsx"
MyFolder = "C:\Users\juan\Desktop\ww\weather"
MyFile = Dir(MyFolder & "\*.xls")
Do While MyFile <> ""
    Workbooks.Open Filename:=MyFolder & "\" & MyFile
    MyFile = Dir
    Sheets.Copy
    Sheets.Copy Before:=Workbooks("xx.xlsx").Sheets(1)
    Workbooks(MyFile).Close savechanges:=False 'it gives me the problem here on the when it is going to save the second file
Loop
End Sub
thank you
↧

Extract data from tables in Word to Excel

May 19, 2016, 2:44 am
$
0
0
Dear all,

I'm trying to extract data from Word to Excel. The data is contained in tables and subtables within these tables.
The main tables are divided into "sections".

In these sections I need to extract the "chapter" and "title" given that the section has a subtable.
The "chapter" and "title" can have the form "A.1" and "Title title title". The title is placed 3 cells above the subtable in the Word table. See image for better description.

I could give the subtables a name in Word, which is the way it is done in the attached code.
The problem is that the title changes depending on the project, so ideally I would like to offset from the location of the subtable to get the chapter and title.

I've attached a picture of the Word table and the current code in Excel VBA (sorry for Danish commenting)

Thank you!

Forum.png

Code:

Sub Importer_KS_Tabeller()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tableRows As Integer
Dim tableStart As Integer
Dim tableTot As Integer
Dim subtableStart As Integer
Dim subtableTot As Integer
Dim cursubTable As Integer
Dim HovedTitel As String
Dim Undertabel_titel As String
Dim lSpace As Long
Dim rSpace As Long
Dim SubtableCounter As Integer
Dim MissingTitle As Integer

On Error Resume Next

'Ryd Excel arket
ActiveSheet.Range("A:AZ").ClearContents
ActiveSheet.Range("A:AZ").ClearFormats

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Vælg standdardbeskrivelse hvor KS-tabeller skal udtrækkes fra")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)

Set wdDoc = GetObject(wdFileName) 'open Word file

'With wdDoc
    tableTot = wdDoc.Tables.Count
    If tableTot = 0 Then
      MsgBox "Dokumentet indeholder ingen tabeller.", _
      vbExclamation, "Importer Word Tabel"
  'ElseIf tableNo > 1 Then
  ' tableNo = InputBox("Standardbeskrivelsen indeholder " & tableNo & " tabeller." & vbCrLf & _
    '  "Vælg hvilken der skal startes fra", "Importer Word tabel", "1")
  End If

 'Indsæt hovedoverskrift (fx 01 - Tag)
    'Indsæt nummer og titel
    HovedTitel = WorksheetFunction.Clean(wdDoc.Tables(1).Cell(1, 1).Range.Text)
   
    lSpace = InStr(HovedTitel, " ")
   
    rSpace = InStrRev(HovedTitel, " ")
           
    Cells(2, 1) = "'" & Trim(Left(HovedTitel, lSpace))
   
    Cells(2, 2) = "'" & Trim(Right(HovedTitel, rSpace))
       
    'Tilføj formatering på hovedoverskrift
    Range(Cells(2, 1), Cells(2, 2)).Font.Name = "Melior LT Std"
    Range(Cells(2, 1), Cells(2, 2)).Font.Size = 18
   
'Vælg linje hvor de kopierede tabeller skal indsættes
  resultRow = 4

'With .Tables(tableStart)

'START LOOP MED HOVEDTABELLER
        For tableStart = 2 To tableTot
            'Indsæt underoverskrift (fx. 01.A Udskiftning af tegl...)
                     
            'Indsæt nummering
            Cells(resultRow, 1) = WorksheetFunction.Clean(wdDoc.Tables(tableStart).Cell(1, 1).Range.Text)
            'Indsæt titel
            Cells(resultRow, 2) = WorksheetFunction.Clean(wdDoc.Tables(tableStart).Cell(1, 2).Range.Text)
           
            'Tilføj formatering
            Range(Cells(resultRow, 1), Cells(resultRow, 2)).Font.Name = "Calibri"
            Range(Cells(resultRow, 1), Cells(resultRow, 2)).Font.Size = 13
            Range(Cells(resultRow, 1), Cells(resultRow, 2)).Font.Bold = True
                     
            resultRow = resultRow + 2
           
'Stop
'START LOOP MED UNDERTABELLER
            subtableTot = wdDoc.Tables(tableStart).Tables.Count
                    For cursubTable = 1 To 2 'subtableTot
                            'Kig kun i cellen (1,1)
                                  If WorksheetFunction.Clean(wdDoc.Tables(tableStart).Tables(cursubTable).Cell(1, 1).Range.Text) = "Emne" Then
                                     
                                        'Indsæt nummer og overskrift der gælder for aktuel KS-tabel
                                        'Indsæt nummering
                                       
                                        'Tjek om tabeltitel er ens ift. sidste undertabel?
                                       
                                            Undertabel_titel = wdDoc.Tables(tableStart).Tables(cursubTable).Title
                                           
                                                If Undertabel_titel = "" Then
                                                Undertabel_titel = "OBS Mangler_Titel!"
                                                MissingTitle = MissingTitle + 1
                                                End If
                                                                                   
                                            lSpace = InStr(Undertabel_titel, " ")
   
                                            rSpace = InStrRev(Undertabel_titel, " ")
           
                                            Cells(resultRow, 1) = "'" & Trim(Left(Undertabel_titel, lSpace))
   
                                            Cells(resultRow, 2) = "'" & Trim(Right(Undertabel_titel, Len(Undertabel_titel) - lSpace))
                                           
                                            'Tilføj formatering for undertabel titel
                                            Range(Cells(resultRow, 1), Cells(resultRow, 2)).Font.Name = "Calibri"
                                            Range(Cells(resultRow, 1), Cells(resultRow, 2)).Font.Size = 11
                                            Range(Cells(resultRow, 1), Cells(resultRow, 2)).Font.Bold = True
                                           
                                            resultRow = resultRow + 2
                                   
                                    'Indsæt indhold fra undertabel
                                                                                   
                                                For iRow = 1 To wdDoc.Tables(tableStart).Tables(cursubTable).Rows.Count
                                                For iCol = 1 To wdDoc.Tables(tableStart).Tables(cursubTable).Columns.Count
                                                        Cells(resultRow, iCol) = WorksheetFunction.Clean(wdDoc.Tables(tableStart).Tables(cursubTable).Cell(iRow, iCol).Range.Text)
                                                    Next iCol
                                                    resultRow = resultRow + 1
                                                Next iRow
                                   
                                                'Tilføj formattering for undertabel
                                                iRow = iRow - 1
                                                Range(Cells(resultRow - iRow, 1), Cells(resultRow - 1, 4)).Font.Name = "Calibri"
                                                Range(Cells(resultRow - iRow, 1), Cells(resultRow - 1, 4)).Font.Size = 10
                                                Range(Cells(resultRow - iRow, 1), Cells(resultRow - 1, 4)).Borders.LineStyle = xlContinous
                                                Range(Cells(resultRow - iRow, 1), Cells(resultRow - 1, 4)).Borders.Color = RGB(217, 217, 217)
                                               
                                               
                                                Range(Cells(resultRow - iRow, 1), Cells(resultRow - iRow, 4)).Font.Bold = True
                                                Range(Cells(resultRow - iRow, 1), Cells(resultRow - iRow, 4)).Interior.Color = RGB(217, 217, 217)
                                               
                                        'Stop
                                               
                                  SubtableCounter = SubtableCounter + 1
                                 
                                  Else
                                 
                                  'Do nothing

                                  End If
                        'Afstand mellem indsatte KS-tabeller? Hvis ikke fjernes denne linje
                        resultRow = resultRow + 1
                       
                    Next cursubTable
                '**** LOOP MED UNDERTABELLER
        Next tableStart
    '**** LOOP MED HOVEDTABELLER

'Formater alt: Topjuster, Ombryd tekst
Range(Cells(1, 1), Cells(resultRow, 4)).VerticalAlignment = xlTop
Range(Cells(1, 1), Cells(resultRow, 4)).WrapText = True

'End With
       
'End With
       
MsgBox ("Færdig! Der blev udtrukket i alt " & SubtableCounter & " KS-tabeller.")

If MissingTitle > 0 Then
MsgBox ("OBS - Der mangler titel på i alt " & MissingTitle & " KS-tabeller.")
End If

End Sub
↧

Consolidate files with different headers

May 19, 2016, 2:50 am
$
0
0
I have more than 5 files that is possible to have different headers. I am able to locate the folder and scan through each files and put the filenames in the Main tab. Attached is the sample file.

Now, I need to do the following:
[1] scan on each file - already existing on the file
[2] open the file - already existing on the file
[3] delete the 2nd row - already existing on the file
[4] I have to go back to the template file > Data tab
[5] read the 2nd column header of the template file
[6] find the 2nd column header to the opened file
[7] copy the data from the opened file excluding headers (Row 1)
[8] paste it back to the template file
[9] repeat steps 5-8 once all the headers where found, 1st column will fill up with the filename of the opened file
[10] then count all the lines for the file and put it in the Main Tab
[11] then repeat steps 1-10 again when moving the next file
↧
Viewing all 49916 articles
Browse latest View live
Search