Free Microsoft Excel 2013 Quick Reference

Pasting splits in cells Results

Hello,

I got some information on an excel sheet which includes a set of EMail ID s. Now I would like to insert some code ( Macros) into this excel sheet which upon running would send EMails to the people(ID s)listed in the excel sheet. All these EMails should include a predefined subject (present on the excel) and some text in the body along with a couple of attachments. Links(or paths) to all these are provided in the excel sheet. My code takes care of all this i.e it opens the text file from the given link and displays it in the sent mail. It also gathers the listed subject of the mail. But the problem here is that it does not attach the files to the mail being sent.

It just ignores the attachment part.

Im pasting the code i am using here

Please look into it and post your observations

any help would be appreciated

Thanks in advance

Sub MarketGroup()

' setting up various objects
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim attachME As Object
Dim Session As Object
Dim EmbedObj1 As Object
Dim recipient As String
Dim ccRecipient As String
Dim bccRecipient As String
Dim subject As String
Dim bodytext As String
Dim Attachment1 As String
Dim Temprecipient As String
Dim iFileNumber As Integer
Dim callDetailsPath As String
Dim mailSentStatus As String
Dim xlApp As New Excel.Application
Dim xlWrkBk As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim callSummary As String
Dim FileFullPath As String
Dim path As String
Dim arrRecipients As Variant
Dim x As Integer

If MsgBox("Do you want to Proceed?", vbYesNo) = vbYes Then
 
Application.ScreenUpdating = False
Application.EnableEvents = False

path = ActiveWorkbook.FullName
Set xlWrkBk = GetObject(path)
Set xlSht = xlWrkBk.Worksheets(1)

' creating a notes session
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) &
".nsf"
Set Maildb = Session.GETDATABASE("", MailDbName)
 

If Maildb.IsOpen <> True Then
On Error Resume Next

Maildb.OPENMAIL
End If

' setting up all sending recipients

x = 2
While Range("B" & x).Text <> ""
    Set MailDoc = Maildb.CreateDocument
    MailDoc.form = "Memo"
    '--- These variables will be used to search for duplicates.
    recipient = Range("B" & x).Text
    Temprecipient = recipient
    '--- Increment X until a different e-mail address is found.
    recipient = Range("B" & x).Text
    arrRecipients = Split(recipient, ",")
    FileFullPath = Range("E" & x).Text
    iFileNumber = FreeFile
    Open FileFullPath For Input As #iFileNumber
    bodytext = Input(LOF(iFileNumber), #iFileNumber)
    Close (iFileNumber)
    
bccRecipient = "abc@xyz.com"
subject = Range("F" & x).Text
mailSentStatus = Range("G" & x).Text
 

'// Lets check to see if form is filled in Min req =Recipient, Subject, Body Text
If recipient = vbNullString Or subject = vbNullString Or bodytext = vbNullString Then
MsgBox "Recipient, Subject and or Body Text is NOT SET!", vbCritical + vbInformation
xlWrkBk.Save
Exit Sub

End If
If mailSentStatus = "NO" Then
' loading the lotus notes e-mail with the inputed data
With MailDoc
.sendto = arrRecipients
.blindcopyto = bccRecipient
.subject = subject
.body = bodytext
End With

' saving message
MailDoc.SaveMessageOnSend = True

callDetailsPath = Range("C" & x).Text
If callDetailsPath <> "" Then
Set attachME = MailDoc.CREATERICHTEXTITEM("callDetailsPath")
Set EmbedObj1 = attachME.EMBEDOBJECT(1454, "", callDetailsPath, "Attachment")
MailDoc.CREATERICHTEXTITEM ("Attachment")
End If


callSummary = Range("D" & x).Text
If callSummary <> "" Then
Set attachME = MailDoc.CREATERICHTEXTITEM("callSummary")
Set EmbedObj1 = attachME.EMBEDOBJECT(1454, "", callSummary, "Attachment")
MailDoc.CREATERICHTEXTITEM ("Attachment")
End If

' send e-mail !!!!
MailDoc.PostedDate = Now()

' if error in attachment or name of recipients
'On Error GoTo errorhandler1
xlSht.Cells(x, "G") = "YES"
MailDoc.Send 0, arrRecipients
End If
x = x + 1
Wend
Application.ScreenUpdating = True
Application.EnableEvents = True
xlWrkBk.Save
Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
xlWrkBk.Close

'Unload Me

Exit Sub

' setting up the error message
errorhandler1:

xlWrkBk.Save
MsgBox "Incorrect name supplied or the attachment has not attached," & _
"or your Lotus Notes has not opened correctly. Recommend you open up Lotus Notes" & _
"to ensure the application runs correctly and that a vaild connection exists"

Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
xlWrkBk.Close

' unloading the userform
'Unload Me

End If

End Sub


Hi,

I have the following macro that imports data from multiple tables in access. I am running into the issue that during the 10th Loop I am getting an error on the ".Refresh BackgroundQuery:=False" line. I tried splitting up the loop into groupings of nine with the same results occuring on the first occurance of the second loop.

Sub
Import()
'
' Import Macro

'

'
Dim sCondo, scondo2, scondo3, scondo4, scondo5, scondo6, scondo7, sTab As String

Sheets("update").Range("N1").Select

Do

Sheets("update").Range("A1").Value = ActiveCell.Value


sCondo = Worksheets("update").Range("c1")
scondo2 = Worksheets("update").Range("c2")
scondo3 = Worksheets("update").Range("c3")
scondo4 = Worksheets("update").Range("c4")
scondo5 = Worksheets("update").Range("c5")
scondo6 = Worksheets("update").Range("c6")
scondo7 = Worksheets("update").Range("c7")
sTab = Worksheets("update").Range("A1")




Worksheets("model").Select




    With ActiveSheet.QueryTables.Add(Connection:=Array( _
        "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data
Source=F:excelSHARESpecial Projects2010Receivables" _
        , _
        "Data Dump.mdb;Mode=ReadWrite;Extended Properties="""";Jet OLEDB:System
database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Databas" _
        , _
        "e Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global
Partial Bulk Ops=2;Jet OLEDB:Global Bul" _
        , _
        "k Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System
Database=False;Jet OLEDB:Encrypt Database=False;Jet " _
        , _
        "OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet
OLEDB:SFP=False" _
        ), Destination:=Range("a4844"))
        .CommandType = xlCmdTable
        .CommandText = Array(sCondo)
        .Name = "Data Dump"
        .FieldNames = False
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceDataFile = _
        "F:excelSHARESpecial Projects2010ReceivablesData Dump.mdb"
        .Refresh BackgroundQuery:=False
    End With
    
    
       
Cells.Copy
Sheets(sTab).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

Worksheets("update").Select
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell = ""
 

    
End Sub
The query tables occur seven times per loop but we removed them due to spacial limitations in this thread.

Any help would be greatly appreciated. Thanks

Calling all experts!!

I am working on a project that needs to do some heavy data manipulation to approx 500,000 records per month. I have created a number of macros that are manually run by a user (a single user whom I have trained) on each worksheet within a workbook. The essential functions for each of the 5 macros are:

1. Find and Replace macro that searches for a corrects incorrect or common mispellings.
2. Location macro that separates out the two-letter State abbreviation from a column and creates a new column for it. This macro also 'Paste Special - Values' into a new column and then deletes the column with the Trim formula.
3. Split Cell macro that trims out specific data contained in one column and divides it into 3 columns.
4. Paste Values macro that does the 'Paste Special - Values' function to the above newly created columns and deletes the columns with the Trim formulas.
5. New Sheets macro that cleans up unused rows and hidden columns.

Note: The reason for the 'Paste Special - Values' functions are that this data is imported into an Access Database following manipulation in Excel.

Now the problem.....I have created these macros on my machine in my home office and copied them onto the target machine at the business where it is to be used. Both machines are relatively new running XP and Office 2003. The target machine is on a local, hardwired network.

While I had unqualified, initial success on the target machine for one monthly cycle....now the macros run unacceptably slow on the target machine. I am able to run all five macros through 7 worksheets on my machine in about 30 minutes...perfectly acceptable considering the amount of data! While I have not done a complete run-through on the target machine....it appears that it would take many hours for one worksheet.

I have:
Turned off network connections (and even unplugged the LAN cable) on the target machine - no help
Made sure that I have a self-certified digital certificate on the target machine for myself and the user
Re-created the macros on the target machine by cutting and pasting the code into new macros
The perplexing issue for me is why is works so flawlessly on my machine, but is slower than a glacier on the target machine.

I have seen the "Screen Updating/Application Calculation" sub that I may try....but I am not overly hopeful!

Any thoughts/advice would be greatly appreciated!!

Thanks!!

THOUGHTS:
1.) Is there a better way of doing the entire project?
2.) Would it work better if the data were split into 253 separate sheets each with one column and the match done against sheet names?
3.) Would it work better if the data were split into 253 separate text files each with one column, the match done against names and then that text file imported?
4.) Could it all be done using something like (with column count rows)?

STRUCTURE:
The workbook structure consists of:
SHEETS Master - where the output is presented.
SHEETS Country - just holds the list of 253 entries for the drop list in SHEETS master.
SHEETS Data - holds all the data in a table with 254 columns varying in size from 1 cell to 44090 cells
SHEETS OffsetData - this is only being used to output the offset data whilst I am trying to debug the coding.
SHEETS CleanUpData - this is only being used to output the cleaned up data whilst I am trying to debug the coding.
Full workbook size without populating SHEETS Master is 7,752 KB (7.7 MB)
Full workbook size with SHEETS Master populated with 44090 cells in column B is 25,742 KB (25.7 MB)

FURTHER REFERENCE:
http://www.excelforum.com/excel-gene...r-columns.html

ISSUES:
If I use the VBA code as shown Ref: Code A then the output to SHEETS Master takes up to 2 seconds,
however it outputs a lot of 0(zero) values in SHEETS Master Column B which in turn causes unnecessary data in
SHEETS Master Columns D,E,F,G as seen in Ref: Fig 1

If I use the VBA code as shown Ref: Code B then the output to SHEET Master takes up to 6 minutes
however it outputs no 0(zero) values in SHEETS Master Column B which in turn causes virtually no unnecessary data in
SHEETS Master Columns D,E,F,G as seen in Ref: Fig 2

The code difference is given in Ref: Code C

Ref: Code A
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim RNA As Range
 Dim RNC As Range
 Dim RNG As Range
 
  Application.EnableEvents = False
    
 On Error Resume Next
  If Target.Address = "$A$1" Then
    ActiveSheet.UsedRange.Offset(1).Clear
  End If

 With Sheets("OffsetData").Select
 Range("$A$1:$A$44090").Select
   Selection.FormulaArray =
"=OFFSET(InnerTable,0,MATCH(Master!$A$1,OFFSET(Table,0,0,1,COLUMNS(Table)),0)-2,ROWS(InnerTable),1)"
   Selection.Copy
 End With

 With Sheets("CleanUpData").Select
 Range("$A$1:$A$44090").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
   For Each RNC In Sheets("CleanUpData").Range("$A$1:$A$44090")
    If RNC.Value = "0" Then RNC.ClearContents
   Next RNC
   Selection.Copy
 End With

 With Sheets("Master").Select
 Range("$B$1:$B$44090").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
 End With
    
  Set RNG = Range("$B$1:$B$44090").SpecialCells(xlConstants)
   If Not RNG Is Nothing Then
    RNG.Offset(1, 2).FormulaR1C1 = "=""Deny from "" & RC[-2]"
    RNG.Offset(1, 3).FormulaR1C1 = "=""Allow from "" & RC[-3]"
    RNG.Offset(1, 4).FormulaR1C1 = "=""/sbin/iptables -A INPUT -p udp -s "" & RC[-4]&
"" -j DROP"""
    RNG.Offset(1, 5).FormulaR1C1 = "=""/sbin/iptables -A INPUT -p tcp -s "" & RC[-5]&
"" -j DROP"""
   Else
    ActiveSheet.UsedRange.Offset(1).Clear
   End If
    Application.EnableEvents = True
End Sub
Ref: Fig 1
Fig 1.gif

Ref: Code B
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim RNA As Range
 Dim RNC As Range
 Dim RNG As Range
 
  Application.EnableEvents = False
    
 On Error Resume Next
  If Target.Address = "$A$1" Then
    ActiveSheet.UsedRange.Offset(1).Clear
  End If

 With Sheets("OffsetData").Select
 Range("$A$1:$A$44090").Select
   Selection.FormulaArray =
"=OFFSET(InnerTable,0,MATCH(Master!$A$1,OFFSET(Table,0,0,1,COLUMNS(Table)),0)-2,ROWS(InnerTable),1)"
   Selection.Copy
 End With

 With Sheets("CleanUpData").Select
 Range("$A$1:$A$44090").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
   Selection.Copy
 End With

 With Sheets("Master").Select
 Range("$B$1:$B$44090").Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
 End With
    
  Set RNG = Range("$B$1:$B$44090").SpecialCells(xlConstants)
   If Not RNG Is Nothing Then
    RNG.Offset(1, 2).FormulaR1C1 = "=""Deny from "" & RC[-2]"
    RNG.Offset(1, 3).FormulaR1C1 = "=""Allow from "" & RC[-3]"
    RNG.Offset(1, 4).FormulaR1C1 = "=""/sbin/iptables -A INPUT -p udp -s "" & RC[-4]&
"" -j DROP"""
    RNG.Offset(1, 5).FormulaR1C1 = "=""/sbin/iptables -A INPUT -p tcp -s "" & RC[-5]&
"" -j DROP"""
   Else
    ActiveSheet.UsedRange.Offset(1).Clear
   End If
    Application.EnableEvents = True
End Sub
Ref: Fig 2
Fig 2.gif

Ref: Code C
For Each RNC In Sheets("CleanUpData").Range("$A$1:$A$44090")
    If RNC.Value = "0" Then RNC.ClearContents
   Next RNC
RESOLVE:
???

Hello there,

A few months ago someone on this forum graciously helped me write the code below. Now I am looking to expand this a little and I was hoping that someone could help me out. Currently this macros imports any files with extension .asc in the same directory as the .xls file, pastes them into a new worksheet, then adds a column corresponding the filename. My issue is that I would rather the data be pasted in the worksheet "Raw Data" (Starting B2 in the attached example). Right now the macros just creates a new worksheet to paste the data into which is fine but I was hoping to be a little more efficient.

Any help, pointers or nudges in the right direction would be much appreciated.

Thanks in advance!

Sam

Macros in the attached "Import and Paste Macro Directed.xls" file:

Sub Import()

  Dim FSO As Object
  Dim fPath As String
  Dim fName As String
  Dim R As Long
  Dim wbNew As Worksheet
  Dim TextFile As Object
  Dim Text As Variant

   fPath = ThisWorkbook.Path & ""   'don't forget the final  in this string
   fName = Dir(fPath & "*.asc")                     'filename filter, get 1st filename

   R = 1
    Set wbNew = Worksheets.Add

      Set FSO = CreateObject("Scripting.FileSystemObject")

      Do While Len(fName) > 0

        Set TextFile = FSO.OpenTextFile(fPath & fName, 1, False)
    

      
          Do While Not TextFile.AtEndOfStream
            Text = Split(TextFile.ReadLine, " ")
            Cells(R, "A") = fName
            Cells(R, "B").Resize(1, UBound(Text, 1)).Value = Text
            R = R + 1
          Loop
      
        TextFile.Close
        
       'get next filename
        fName = Dir()
    
      Loop
    
  Range(Selection, Selection.SpecialCells(xlLastCell)).Select
 
     For Each xCell In Selection
        xCell.Value = xCell.Value
    Next xCell
    
     MsgBox "Process Finished"
End Sub


I am having an issue in that I am using various formulas to move, split data, etc from various sources.
The problem is when my final results post to the final destination that I want, I still need to either run advanced filters, or a vlookup with the results. I can’t do this because as an example
if cell A1 shows a value of: A127
the actual cell content is: =RIGHT(A2,FIND(" ",A2&" ")-2)

Everything I read said to copy and paste special values, but this doesn’t work for me as the idea is to have the formulas/macros run everything and eliminating cutting and pasting.
In the case above I have a formula that pulls that info from a spreadsheet that is saved every week. Once it is pulled part of it is cut out in another column. I then need to run a vlookup on those results for data already contained on another tab.

Hi guys,
I really need some help with a complex problem i am having.

I have been given about 90,000 rows of data.
Split into modules, and the modules are in chassis'.

Now.
Some of the modules have reached their termination date, others haven't.
What i need to do is find out which chassis' have no modules in them that have reached their termination date? If the chassis has one module that has reached its termination date then the whole chassis has to be classed as past its termination date.

I have tried sorting and filtering but i split up the chassis' if i do this and then I don't know if the chassis has just one module that is past its termination date?

If it helps module cells that have reached their termination date have a coloured background. If not they are white.

Any help to this very complex problem would be so greatful.

Many Thanks.

Ive attached a spreadsheet that I put together tonight with a macro and some examples. Try not to laugh at my macro. I know its bad and not efficient, but since I am still new to macros and absolutely suck at anything code related, it will take me 50 hours to make it nice. So, Im happy with it just working

I want to use this spreadsheet to track billable hours against each of my projects. This worksheet will allow me to enter time hours for each project and at the end of the week click the button on the first sheet and have all the information compiled into one sheet in order of project with the ID, name, date of work, description of billable time, number of hours, and the total hours for that project this week. The total hours field is a little weird, as its on the first row only of that projects list of entries in the project's worksheet and the first sheet where all projects will be listed. It is the only place I could think to put it that would allow me to see it on each sheet and prevent excess rows from being pasted into the first sheet.

Here is my issue, as I close certain projects and open other projects, I do not want to have to manually edit my macro to account for the deletion of sheets, or the addition of new sheets. I know I could add a message box that would allow me to type in the project name and add a new sheet with that name, but that is where my knowledge stops. I dont know how to also apply the worksheet name to a table name and also apply the changes to a Macro through the message box input.

On the flip side, is there just an easier way to go about this? Basically all I need on that first sheet is the ID, project name, and total hours billed listed once for each project followed by all of the descriptions of billable time and the hours for each description. The only reason I am currently using tables in the sheets is because I can filter out the blank rows so that Im not copying a ton of blank rows each time I copy and paste from one sheet to that first sheet.

As an example, it would be fine if that first sheet looked like this, rather than having column entries duplicated for each row, but its not a big deal either way:

SP ID 1234 Project A Total Hours Billed 15
Date Description of Billable Time Hours Billed
28-Feb-11 Project description entry 1 5
02-Mar-11 Project description entry 2 10

SP ID 5678 Project B Total Hours Billed 25
Date Description of Billable Time Hours Billed
01-Mar-11 Project description entry 1 15
02-Mar-11 Project description entry 2 10

If anyone has any suggestions, Id really appreciate the help.

Thanks.

Current Macro:
Sub CompileWeeklyHours()
'
' CompileWeeklyHours Macro
'

'
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets("All Project Billable Hours").Select
    Cells.Select
    Selection.Clear
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "All Recorded Billable Hours "
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "SP ID"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "Project Name"
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "Date of Work"
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "Description of Billable Time"
    Range("E3").Select
    ActiveCell.FormulaR1C1 = "Hours Billed"
    Range("F3").Select
    ActiveCell.FormulaR1C1 = "Total Hours Billed"
    
    Sheets("SDL - Jonesboro radd002 Split").Select
    ActiveSheet.ListObjects("TableJonesboroRadd002Split").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableJonesboroRadd002Split").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    'Sheets("SDL - Jonesboro radd002 Split").ShowAllData
    
    
    Sheets("SDL - Carthage N2D").Select
    ActiveSheet.ListObjects("TableCarthageN2D").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableCarthageN2D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
        Sheets("SDL - Stuttgart N2D").Select
    ActiveSheet.ListObjects("TableStuttgartN2D").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableStuttgartN2D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste

    Sheets("Insight Part 1").Select
    ActiveSheet.ListObjects("TableInsightPart1").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableInsightPart1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
       Sheets("Admin Time").Select
    ActiveSheet.ListObjects("TableAdminTime").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableAdminTime").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
       Sheets("Documentation and Process").Select
    ActiveSheet.ListObjects("TableDocsProcess").Range.AutoFilter Field:=5, Criteria1:= _
        "<>"
     Range("TableDocsProcess").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("All Project Billable Hours").Select
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    
        Sheets("All Project Billable Hours").Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.ClearFormats
    
    Range("A2:F2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
        Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A3:F3").Select
        With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
    Columns("C:c").Select
    Selection.NumberFormat = "[$-409]d-mmm-yy;@"
    
    'Columns("E:F").Select
    'With Selection.NumberFormat = "0.0"
    'End With

    
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    Range("a1:f1").Select
    
    
    Dim ws As Worksheet
    On Error Resume Next
    For Each ws In ActiveWorkbook.Worksheets
    ws.ShowAllData
    Next ws
    On Error GoTo 0


    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub


I have a loop that works for one sheet, and when i have about 40,000 lines it works fine. But then i have some other data, which is about 500,000 lines, & when i split it into 20,000 or however it causes an error in the loop. The loop runs, but then eventually says theres too much data & afterwards it wont save either and the loop wont run.

' this
works fine if i have 30,000 rows or 45000
Sub adcls()
Dim Rng As Range
Dim iCell As Range


Set Rng = Range("b11:b" & Cells(Rows.Count, 2).End(xlUp).Row)
    For Each iCell In Rng
          If iCell.Offset(0, 2) = "1324I" Then
        iCell.Resize(1, 4).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    End If
Next iCell



End Sub

'this one causes errors, even if i cut data to 3000 lines for sheet #2 it eventually says 

'too much data

Sub nowrk()
Dim Rng As Range
Dim iCell As Range


Set Rng = Range("b3:b" & Cells(Rows.Count, 5).End(xlUp).Row)
    For Each iCell In Rng
          If iCell.Offset(0, 1) = "CC" Then
        iCell.Resize(1, 9).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ElseIf iCell.Offset(0, 1) = "2dt" Then
    iCell.Resize(1, 26).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ElseIf iCell.Offset(0, 1) = "Dates" Then
    iCell.Resize(1, 27).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   
    End If
Next iCell



End Sub
any help and guidence on this data error, is the data corrupted? Do I need to paste the data as special values of some time in order for the loop to continue to run. Sometimes it runs about 15,000 rows and then crashes, then i tried doing 4,000 rows but then crashes at 3,000 rows (the second program).

any help, appreciated,

Scratching my head on this one...

I'm trying to put together a spreadsheet that will be used to record employee attendance / performance

I have one spreadsheet that contains a separate sheet for each employee, this will be updated by one administrator. I want supervisors to be able to see all sheets (except for other supervisors), but be able to edit all sheets (except their own)

Non supervisors can only view their own sheet, not edit

Not really sure if I do this all with one single excel file, or whether I would need separate spreadsheets??

So far I have split these into three spreadsheets - Admin - Supervisor - User

I have managed to record a macro for the "Admin" spreadsheet- that copies a cell range (in one of the employee sheets) to the corresponding sheet in the "Supervisor" spreadsheet - but all blank cells copied show as "0" and formatting is ignored

Can anyone tell me how I can ignore blank cells when copying - also retain the format??

Sub Copy()
'
' Copy Macro
'
' Keyboard Shortcut: Ctrl+f
'
    Range("A4:AF15").Select
    Selection.Copy
    Windows("assembly checker board 2009 - Supervisor.xls").Activate
    Range("A4:AF15").Select
    ActiveSheet.Paste Link:=True
    Range("A4:AF15").PasteSpecial xlPasteComments
    Application.CutCopyMode = False

End Sub


Help I cannot figure out how to check two worksheets to
return a value. The lookup is for part number price and
description workbook. Excel dose not have enough rows for
the data so I had to split it. My customers do not have
access they do have excel. Some numbers start with
letters (letters sheet) the rest numbers (numbers sheet).
The part number is in the A column in both. I tried
vlookup it works great to bring back one or the other.
This leaves two cells one with data one #n/a. I cannot
get both together I tried : + & , = Excel fixed it once
when I used the : but it was invalad. I am not opposed to
using a dummy cell or two to change things. I have been
working that angle for the past few hours. I get the #n/a
whitch seems to kill many of the lookup functions. I
converted it to iserror that got me T F but you cannot
seem to get T F to refreance the cell that has the data.
I tried to refreance the data from access but it keeps
trying to bring it all in (makes for a break till cancel
kicks in) I saw a couple of posts for similar things but
they do not look close enough. There must be a simple way
to do this.

Thank you,
Clay

Hey guys,
Firstly I have found this forum very helpful in the past when solving Excel problems. But I'm really struggling with this issue.

I have 2 dates, a start date and an end date. I have worked out how to find the difference between the two (thank you excel forum) but now I need to find the Average time and I am struggling because my cell contains numbers and text.

Here is my example:

Step One

Start date: 30/6/2011
End date: 22/6/2011

Time Taken (formula): =IF(DATEDIF(B7,B8,"y")=0,"",DATEDIF(B7,B8,"y")&" years ")&IF(DATEDIF(B7,B8,"ym")=0,"", DATEDIF(B7,B8,"ym")&" months ")&DATEDIF(B7,B8,"md")&" days"

Time Taken (answer): 3 months 19 days <-- all displayed in one cell to make it neat.

Step Two

Now I have a list of different lengths of time, I need to find the average time taken from this list. When I use =AVERAGE(Cell1,Cell2, Etc...) it returns #DIV/0!

I went the long winded route and split the years months and days into 3 columns without text but the formula averages each 3 separately and does not take into consideration that I am using length of time rather than numbers.

If anyone can help me I would greatly appreciate them. Also if you could briefly explain why it works so that I can learn from it then that would be amazing.

Thank you guys

Hi,

I have recorded the below Macro (basically splits out a long text string into something readable, with headers etc)

What I would like is to be able to amend this, so that instead of copying and pasting the data from the source file into an excel template, I can just open the .xlt and be prompted for the file name/file path of the file with the data in and it be automatically formatted as below.

Also, it would be good if once formatted, it was saved as .xls in the same location as the source file.

Not sure if this is possible, probably is, but beyond my level of knowledge.

There a quite a few of these macros, so is reasonably time consuming copying and pasting all the relevant data.

' Keyboard Shortcut: Ctrl+m
'
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 1), Array(7, 1), Array(11, 1), Array(17, 1), _
        Array(20, 1), Array(22, 1), Array(26, 1), Array(31, 1), Array(34, 1), Array(47, 1), Array( _
        48, 1), Array(56, 1), Array(57, 1), Array(66, 1), Array(69, 1)), TrailingMinusNumbers _
        :=True
    ActiveWindow.SmallScroll Down:=-60
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "3"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "4"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "5"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = 6"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "7"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "8"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "9"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "10
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "11"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "12"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "13"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "14"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "15"
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A27").Select
    Range(Selection, Selection.End(xlUp)).Select
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Font.Bold = True
    Cells.Select
    Cells.EntireColumn.AutoFit
    ActiveWindow.SmallScroll Down:=-186
    Range("C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.NumberFormat = "0000"
    Range("E26").Select
    ActiveWindow.SmallScroll Down:=-12
    Columns("C:C").ColumnWidth = 9.43
    ActiveWindow.SmallScroll Down:=-12
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("B:B").ColumnWidth = 10.57
    Columns("C:C").ColumnWidth = 10.29
    Columns("E:E").ColumnWidth = 7.86
    Columns("E:E").ColumnWidth = 8.86
    Rows("1:1").EntireRow.AutoFit
    Rows("1:1").RowHeight = 33.75
    Columns("G:G").ColumnWidth = 3.86
    Columns("G:G").ColumnWidth = 6.14
    Columns("G:G").ColumnWidth = 8.86
    Columns("G:G").ColumnWidth = 9.86
    Columns("G:G").ColumnWidth = 11
    Columns("H:H").ColumnWidth = 12
    Columns("I:I").ColumnWidth = 5.29
    Columns("I:I").ColumnWidth = 7.57
    Columns("J:J").ColumnWidth = 11
    Range("K1").Select
    Columns("K:K").ColumnWidth = 8.43
    Rows("1:1").EntireRow.AutoFit
    Columns("M:M").ColumnWidth = 5.71
    Columns("O:O").ColumnWidth = 10.86
    Columns("O:O").ColumnWidth = 9.86
    Columns("O:O").ColumnWidth = 8.57
    ActiveWindow.SmallScroll Down:=-6
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
End Sub


In the past I would use delimiter options when importing a text file for this problem, unfortunately this time I cant. When I use the minus sign ("-") as a delimiter it adds another column. Which messes up the column headings.

Can some one provide an example how to remove the minus sign from these types of string examples?
#x-x
Where "x" can be 1 or more characters (Numeric-Numeric Alpha) and the count would be unknown.
Examples:
#x-x
#xx-x
#x-xx
etc.

My code: (Assume all variables are declared).
Mind you, I'm no guru at this.
        For Each Sh4Cell In Sh4Range
            If IsNumeric(Sh4Cell) Then
                If Left(Sh4Cell.Offset(0, -4).Value, 1) = "#" Then
                    sBubbleNumber = Split(Replace(Sh4Cell.Offset(0, -4), "#", "", 1), "")(0)
                    'sActual = Sh4Cell.Value
                    sActual = Replace(Sh4Cell.Value, "-", "", 1, 1)
                    'MsgBox sActual 'for testing

                    For Each Sh3Cell In Sh3Range
                        'MsgBox Sh4Cell.Value & " " & sBubbleNumber
                        If Sh3Cell = sBubbleNumber Then
                            'MsgBox Sh3Cell.Value & " x " & sBubbleNumber & " x " &
sActual
                            If Sh3Cell.Offset(0, 14).Value = "" Then    '0, 14
                                Sh3Cell.Offset(0, 14).Value = sActual    '0, 14
                                'MsgBox ActiveCell.Address & "" & ActiveCell.Value & " "
& sActual 'for testing
                            Else
                                'Place lowest value in left cell and highest value in right cell
                                If Sh3Cell.Offset(0, 14).Value > sActual Then
                                    If Sh3Cell.Offset(0, 14).Value > Sh3Cell.Offset(0, 15).Value Then
                                        Sh3Cell.Offset(0, 15).Value = Sh3Cell.Offset(0, 14).Value
                                        Sh3Cell.Offset(0, 14).Value = sActual
                                    End If
                                End If
                                'Over write left cell if new value is less than existing value
                                If sActual < Sh3Cell.Offset(0, 14).Value Then
                                    Sh3Cell.Offset(0, 14).Value = sActual
                                Else
                                    'Over write right cell if new value is greater than existing value
                                    If sActual > Sh3Cell.Offset(0, 15).Value Then
                                        Sh3Cell.Offset(0, 15).Value = sActual
                                    End If
                                End If
                            End If
                        End If
                    Next Sh3Cell
                End If
            Else
            End If
        Next Sh4Cell
    End If
This code works fine, except for values as previously described.
I have attached an image showing what some of the data looks like imported.

Any hints, tips or examples are appreciated.

I have brought this problem up in the past but found it difficult to explain. I have a new approach on it after studying it and felt it best to start a new thread.

I have found a starting and ending point that I am hoping will incorporate itemized lists into a converted html report.

Here is the current coding that I use and it works great until encountering itemized lists;

Dim a, b, i As Long, k As Long, n As Long, j As Long, zctrl As Integer, Lrow As
Long, istop As Long
Application.ScreenUpdating = False
On Error Resume Next
    Do
        ActiveSheet.Rows.Find("SUB-OFFICE:", , , xlPart).Delete
    Loop Until Err.Number <> 0
On Error GoTo 0: Err.Number = 0: j = 1
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
a = Range([a1], Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).Value
ReDim b(1 To UBound(a), 1 To 13)
For i = 1 To UBound(a)
    If Split(Trim(a(i, 1)), ":")(0) = "CASE NO" Then
        On Error Resume Next
        istop = ActiveSheet.Range(Cells(i, 1), Cells(Lrow, 1)).Find("CASE NO TOTAL", , , xlPart).Row - 4
            If Err.Number <> 0 Then Exit For
        k = i: zctrl = -1
        Do
            n = n + 1
            b(j, n) = a(k, 1): k = k + 1
            If n + zctrl = 12 And k <> istop Then j = j + 1: n = 1
        Loop Until k = istop + 1 Or k = UBound(a)
        j = j + 1: n = 0
    End If
Next
On Error GoTo 0
Sheets(2).Activate: Range([a1], Cells(j, UBound(b, 2))) = b
[a:l].EntireColumn.AutoFit
Note this code was given to me and my understanding of it is limited at best.

I have attached a workbook, which contains a replica of the report, including itemized lists.

I found that the cell APPRAISEL DATE: always proceeds each itemized lists and that is the only time it will appear in the report. The other constant is that at the end of each itemized list is a cell with "N" in it. This is found three rows below the end of each itemized list. I marked them in red to stand out.

My hope is that someone can use those two constants to convert the itemized lists from column A to the appropriate columns, which I showed in the workbook.

Please let me know if there is anything further that I can do to in getting the above coding modified to incorporate itemized lists.

Thanks,

Dave