Free Microsoft Excel 2013 Quick Reference

Macro to merge blank cells in a column Results

I have a worksheet with over 2000 rows and 6 columns and I would like
to
consolidate some multi-row entries into a single line.

The format for many (but not all) of the entries is this:

text1 | text2 | text3 | titleA | titleB | titleC
| | | 123456 | somestuff |
calculatedvalueX

Where the first three cells of the second line are blank.

I would like to perform the following action:
1) Cut the values in the last three cells of the second line.
2) Paste those values into the equivalent cells of the first line.
3) Delete the second line (now that it does not have any data).

Unfortunately, some entries have this two-line format, while other
entries may have the first line with all six columns populated but
then "n" number of rows with only cell columns D, E, and F populated
(and those first three columns each having merged cells of n-rows).
The entries with "n" number of rows are randomly distributed in the
2000+ row spreadsheet, so I can't know as I'm scanning through the
spreadsheet when I'll encounter a two-line or an n-line entry. For
that
reason, I thought a macro I could call while manually scrolling
through
the rows would work best (later, I'll figure out how to deal with the
n-line
entries, perhaps by putting their values in successive columns in the
same row).

So, how can such a macro be constructed and run so that it does not
have absolute references to cells and rows but can work equally as
well
at row #4 as at row # 444?

(If there's VB code that can do this automagically without the manual
macro application, all the better.)

advTHANKSance.

Trying to break this down into small chunks:
Can anyone help with a macro or formula that combines the text and ">" symbol for each course grouping of text and resets itself for each blank cell between the last text from the previous course and the start of the next course.

Example of data and output (column D) is attached.

This will be used for several thousand courses on data migration, so manual is not an option.
Thanks.
Gene

Similar to my last post, but I'm trying to do this in chunks.

Thank you.
Gene

First time poster here,

I need help writing a macro which I will link to a button. Here is what I'm looking for:

I have 4 columns of data starting in rown B29 and ending in G29 (one of the columns is actually 3 merged columns which is populated by a dropdown list). 2 of the columns have formulas.

I would like the user to click the button, which will add a blank row with all the formatting from above (including the same drop down list and formulas). However, I would like to be able to add multiple lines and have the new line always appear at the end of the list.

As if that weren't complicated enough. I want to add another button to act as a 'reset' button which will delete the added rows, leaving me with the original blank row.

I tried recording my own macro but that doesn't work because the merged cells un-merge as the new row is added. And I can't get the new row to always appear at the bottom if I add more than one.

Is that enough info?

Brian

Hello! I've had great success using this forum the past couple of months. Hopefully this entry will be no different!

Attached is a simplistic example of what I'm trying to do automatically with a macro.

In a row, I have various names located in merged cells, one blank cell apart from one another. I would ideally like to have a macro that looks at that row, creates a list in column A where the names are hyperlinked to the cell where the name exists in the row. Basically, I don't want to have to keep scrolling right till I find what I'm looking for. I'd like to have a list in column A so that I can just click on the name I need and be taken to that place in the worksheet. Please see example spreadsheet for what I hope to be the end product.

If you have any questions, please ask! Thank you so much!

basically i have some code below which checks if theres still room on the MWR Template sheet by looking if B32 to H32 is blank. If it is blank then it copies the current row column A and B onto that sheet into cols B and C on the first available blank row on that sheet. If there is no blank row left then it adds a new one at row A9 and paste into that instead.

The issue is i need to merge columns B to H on the MWR Template sheet as users also manually type things sometimes and currently i have had to unmerge it so that the paste operation works without comlpaining about merged cells. So basically what i want to do is modify the current code so that once it has identified which row it wants to paste the 2 cells into on the MWR Template sheet, it will unmerge columns B to H on that row, paste in the data, then re-merge them. This way i can leave it merged by default for users to have plenty of space to type in, and the macro still pastes in without any errors. I am not sure how i can modify the code to do this though. I cannot do this by not using merged cells and simply widening the column because its a form and the extra columns are required at the top.

Currently its a bit crude in that i have the cells unmerged and am centering accross the selection to achieve the same effect, however its still going to cause issues for dumb end users who type into the wrong column because they are not merged. hence i need to merge B to H and still be able to paste into it.

With ActiveSheet
        If Application.WorksheetFunction.CountA(Worksheets("MWR Template").Range("b32:h32")) = 0 Then
            'space
            .Range(.Cells(ActiveCell.Row, 1), .Cells(ActiveCell.Row, 2)).Copy Worksheets("MWR
Template").Range("B32:H32").End(xlUp)(2)
        Else
            'no space
            Worksheets("MWR Template").Range("A9").EntireRow.Insert
            .Range(.Cells(ActiveCell.Row, 1), .Cells(ActiveCell.Row, 2)).Copy Worksheets("MWR
Template").Range("B9")
        End If
        Worksheets("MWR Template").Range("C8:H32").HorizontalAlignment = xlCenterAcrossSelection
    End With


Hi,

I really need any help with this please. Basically I need code which can export certain data from the spreadsheet into a .csv file
I have attached the excel file, which contains some coding and sample data and an example output file. This is the current coding:

Sub Export()
    ' A list of variables
    Dim Stu_getRow As Integer, S_getColumn As Integer
    ' Reset search variable
    Stu_getRow = 4
    Open "c:testout.txt" For Append As #1
    ' Break both loops once limits exceeded
    While Stu_getRow >= 4 And Stu_getRow <= 299
    Print #1, Sheet13.Cells(Stu_getRow, 4).Text & " ---" & Sheet13.Cells(Stu_getRow, 5).Text
    S_getColumn = 8
    While S_getColumn >= 8 And S_getColumn <= 39
    If IsNumeric(Sheet13.Cells(Stu_getRow, S_getColumn).Text) = True Then
    ' Yes input is valid, process it
    Print #1, "SUBJECT CODE: " & Sheet2.Cells(S_getColumn - 6, 2) & " " & Sheet13.Cells(3,
S_getColumn).Text & ": " & Sheet13.Cells(Stu_getRow, S_getColumn).Text
    End If
    S_getColumn = S_getColumn + 1
    Wend
    Stu_getRow = Stu_getRow + 1
    Wend
    Close #2
End Sub

What is needed

I need to be able to export:

* "first name" and "last name" column merged together

If last name doesn't exist it should still consider that row as a valid entry.

* if a subject, for that person, contains a mark then, export that subject's, "subject code" and the mark.

To show there is no mark, the cell will display a "-". If it does this, then the mark, or subject code for that person shouldn't be exported.

* If a cell which should have a mark says "check", then return a popup error stating for which name and subject (not subject mark) the cell contains the value "check". However, it should still export any entries that come after this entry, but not including this entry.

E.g. For Mary, the subject, English reads "Check". Thus all entries prior to and after Mary should still be exported, but that Mary shouldn't be exported. A popup error saying "Please check entry for Mary. Subject: English" should come up after the export.

* Cycle though names from row 4 to 299. - If there is a gap between an entry of the names it should still continue cyling through the entries until row 299, even if they are blank (as there may be a gap between entries and the entries after the gap should not be ignored.

E.g. There is a gap between Harry and Jim. The macro should ignore the row with a blank first name between name entries, however still cylce through to row 299.

* Cylces through subjects until there is a blank subject (unlike the names), it should stop cylcing when it comes across a blank subject cell.

E.g. Stop at "Japanese Continuers"

Current Code:

* The "-" which I want to signify as a blank cell for marks are still exported. These should be considered as blank cells and thus not exported.

* Currently, if a name or mark is updated and then the macro is run to re-export, the output file doesn't appear to be updated with the new and/or changed data.

Output file:

* .csv file

* Output file name and worksheet name should be the year, retrieved from the 'year' worksheet. e.g. 2010.csv

Formatting of output file:

* Column 1: Full name (first name and last name merged together)
* Column 2: Subject Code
* Column 3: Mark
* Column 4: Subject Code
* Column 5: Mark
* etc.

If there are three subjects then there should be 7 columns with data, for that entry (name, 3 marks, 3 subject codes).

If there are four subjects then 9 columns with data for that entry (1 name, 4 marks, 4 subject codes).

* Each row is a separate name entry.

If in the 'Moderated Marks' sheet there is a gap between entries, then that gap should not be exported as an entry. The entries after that gap, however, should be exported as a continuation of the data before the gap.

Thankyou so much for all your help. Much Appreciated.

hi,
this is my 1st post
have the data like this containing employee number, receipt number, postive and negative. I have a macro for knocking off the entry against employee No. as base with receipt no. If the amount is equal with positive and negative.

Ex: Employee having same receipt with same amount in positive and negative should get knocked off.
emp no reciept number positive negative
77777 120a 10000
77777 120a 10000
And the macro for knocking of this entries is
Option Explicit

Sub Consolidate()
Dim lastrow As Long, rng As Range, i As Integer
'Compares two match criteria, merges data in third cell and deletes duplicate lines
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False

'Merge positive values
Range("AA2:AA" & lastrow).FormulaR1C1 = _
    "=IF(RC[-24]="""","""",IF(SUMPRODUCT(--(R2C1:R" & lastrow &
"C1&R2C2:R" & lastrow & "C2=RC[-26]&RC[-25]))>1,SUMPRODUCT(--(R2C1:R" & lastrow
& "C1&R2C2:R" & lastrow & "C2=RC[-26]&RC[-25])),1))"
Range("AB2:AB" & lastrow).FormulaR1C1 = _
    "=IF(RC[-25]="""","""",SUMPRODUCT(--(R2C1:R" & lastrow &
"C1&R2C2:R" & lastrow & "C2=RC[-27]&RC[-26]),R2C3:R" & lastrow &
"C3))"
Range("AB2:AB" & lastrow).Copy
Range("C2").PasteSpecial xlPasteValues
Range("AA:AB").ClearContents

'Merge negative values
Range("AA2:AA" & lastrow).FormulaR1C1 = _
    "=IF(RC[-23]="""","""",IF(SUMPRODUCT(--(R2C1:R" & lastrow &
"C1&R2C2:R" & lastrow & "C2=RC[-26]&RC[-25]))>1,SUMPRODUCT(--(R2C1:R" & lastrow
& "C1&R2C2:R" & lastrow & "C2=RC[-26]&RC[-25])),1))"
Range("AB2:AB" & lastrow).FormulaR1C1 = _
    "=IF(RC[-24]="""","""",SUMPRODUCT(--(R2C1:R" & lastrow &
"C1&R2C2:R" & lastrow & "C2=RC[-27]&RC[-26]),R2C4:R" & lastrow &
"C4))"
Range("AB2:AB" & lastrow).Copy
Range("D2").PasteSpecial xlPasteValues
Range("AA:AB").ClearContents

    Range("AA2:AA" & lastrow).FormulaR1C1 = "=RC[-26]&RC[-25]&RC[-24]"
    Range("AB2:AB" & lastrow).FormulaR1C1 = "=IF(RC[-25]="""",0,COUNTIF(R2C27:R"
& lastrow & "C27,RC[-1]))"
    Range("AC2:AC" & lastrow).FormulaR1C1 = "=IF(RC[-25]="""",0,COUNTIF(R2C27:R"
& lastrow & "C27,RC[-2]))"
    
    For i = lastrow To 2 Step -1
        If Cells(i, "AB").Value + Cells(i, "AC").Value = 1 Then
        Else
            Rows(i).Delete (xlShiftUp)
        End If
    Next i

lastrow = Range("A" & Rows.Count).End(xlUp).Row

    Range("E2:E" & lastrow).FormulaR1C1 =
"=RC[-4]&""-""&RC[-3]&""-""&ABS(SUM(RC[-2]:RC[-1]))"
    Range("F2:F" & lastrow).FormulaR1C1 = "=COUNTIF(R2C5:R36C5,RC[-1])"
    Range("F2:F" & lastrow).Value = Range("F2:F" & lastrow).Value
    
    Range("A1").AutoFilter
    Range("A1").AutoFilter Field:=6, Criteria1:=">1", Operator:=xlAnd
    Range("F2:F" & lastrow).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp

Columns("E:AB").ClearContents
Range("A1").Select
Application.ScreenUpdating = True
End Sub.
it knocks of the positive and negative side perfectly.
If 100 and 50 are under same receipt number in positive side and 150 in negative side of that receipt number it knocks of perfectly.And if there are amount is same In both positive and negative side for eg-250 in positive and 250 in negative side it knocks of perfectly.but this works only if data is in small qty.but if data is in large qty it fails .
it appears error in
consolidation macro
for eg
number reciept number positive
33851 1015/08-09 10000

if the receipt number is in column B2 in containing positive number in excel sheet in middle there are lot of other receipt numbers for eg-1016/08-09 in B3 and 1017/08-09 in B4 with different amounts and there are also some blank cells in middle and the knocking of negative entry 1015/08-09 in B1000 column containing negative value of -10000 at that time macro doesnot knock off and shows a error can these be done.if this could be done it will help me a lot.
thanks in advance
harsha

I have a list of addresses that are sepperated by a blank row. The address
number around 4000. All information is stored in Column A down each of the
rows. Instead, I would like it go across so that it is easy to merge into a
document for mailing. The addresses are similar to those below:

Company Name 1
123 Company Road
Any Town, AL 12345 - 6789
(555) 555-5555

Company Name 2
234 Company Road
Another Town, AK 23456-7890
(555) 555-0000

Company Name 3
Different Town, NY 34567-6543
(555) 555-1111

As you can see, some have three and some have four rows for the address (not
all of them have street addresses in them). What I want is something like
this:

Company Name 1 1234 Company Road Any Town, AL 12345 - 6789 (555)
555-5555
Company Name 2 234 Company Road Another Town, AK 23456-7890 (555)
555-0000
Company Name 3 Different Town, NY
34567-6543 (555) 555-1111

(Please note, I want the phone number in one column as it normally would
appear.) Just so you know, all of the Company Names are bold and of a blue
color (instead of black); not all of the zip codes are nine-digit, some are
five digit; all of the street addresses start with a number or "PO Box"; the
phone numbers are all formatted as (###) ###-#### and are bold; and there is
a blank (empty) cell at the end of each address. I have very little Macro
Programming, but I was thinking of something along the rough idea of:

Go to cell A2 and do the following for each
If the color of the selected cell is blue, then leave it where it is.
Increase the row of column A by 1 (in this case, A3)
If the selected cell begins with a number or "PO Box", then cut and paste it
to Column B one row above it's current spot, else cut and paste it to Column
C one row above it's current spot. Delete the empty cell left from the cut.
If the selected cell begins with a "(", then cut and paste it to Column D
one row above it's current spot. Delete the empty cell left from the cut.
If the selected cell is empty, then delete the empty cell and shift the rows
up.

Obviously this isn't programming language, but I thought I would get my
ideas out on paper first before attempting to get some coding help. Thanks
in advance for anyone's thoughts, comments, suggestions, and help on this!

Aaron

Hey,

I need a macro to go through every row and look at the data in B to K and to squish it all into column M but put it in a reverse order and also retain zero's and blanks.

I tried to do it using some a Right command with some middle commands and then a left but I can't get it to work. I also have a problem with blanks and zero's disappearing...

I've attached a small example in order to try and help

Hi Guys, I'm trying to format another part of my project. Thanks to some great help I've gotten so far it's coming along wonderfully. The problem that I'm having now is I'm copying employee names from Row 2 on one sheet, and pasting them Transposed along Column A (A17) in another sheet. The cells are merged and I have the macro go in and unmerge the cells, but now I have blank rows.

What I need to do is have a macro that will automatically delete the blank rows between line 17 and whatever the last used line is (keeping in mind the data is showing up on odd number lines only.). The macros I've been playing with are deleting every blank line in the entire workbook.

Any ideas? thanks again!

I have a spreadsheet that has a many part #'s, and for each part # it has up to 250 variants. With each variant #, I also need to display a variant name. Right now they are listed vertically, in columns, but I am doing a data merge in InDesign, so I need for each part # and all the variants#'s, variant names, as well as a blank cell for a bar code # to be displayed. This spreadsheet is going to be like... over 1,000 columns wide.

Does anybody know how to take data that is set up in columns and move it over to rows, as well as to insert a blank cell in between each set...

so it is now like.
a b c d
1 Item Variant Description Bar code #
2 942- 1001 Bright White
3 942- 1002 Soft White
4 942- 1003 Black

and I need it set-up like

a b c d e f g
1 Item V1# V1D BC#1 V2# V2D BC#2
2 942- 1001 bright white 1002 Soft White

Hope this makes sense

Can anybody help me with this???

Thank you!!!!

Please keep in mind that I do not know macros... but any assistance would be basically saving my life, and my deadline.

Allene

Hello there

I've got a bit of a challange here, and its a two part question. I'll give you the scenario.

I have a requirement to import Item sales into a particular accounting package. A supplier sends a CSV file outlining their order - however it is not in a format the accounting package needs to successfully import.

So, since the incoming file is csv, it made sense to me to use Excel to adjust it into the required format.

The CSV structure is as follows;

A B C D E
Barcode# ItemDescription Branch Qty Cost
999-991 PK WScrews (20) 112 10 910
999-912 PK Gal.Nails(40) 181 25 880
999-943 CLOTH blue 162 26 870
999-914 PK MASl.Nails(40) 181 5 830
999-978 TBE S.Glue 112 12 720

The aim is to modify this base structure to a form that meets the import conditions of the accounting software. These conditions are

-Decimalised cost, and cost+tax must be present
-Separate invoices with blank rows between items

I have achieved each condition with the following macros

-Decimalised cost, and cost+tax must be present

These guys identify $0.72 as 720, and so I need to divide each cost item by 1000 to make it fit with the accounting software requirements...

Sub Divide_J_By_1000()
'
' Divide_J_By_1000 Macro
' Macro recorded 12/04/2005
'

'
ActiveWindow.LargeScroll Down:=2
ActiveWindow.SmallScroll ToRight:=15
ActiveWindow.SmallScroll Down:=48
ActiveWindow.SmallScroll ToRight:=28
Range("BM221").Select
ActiveCell.FormulaR1C1 = "1000"
Range("BM221").Select
Selection.Copy
ActiveWindow.ScrollColumn = 45
ActiveWindow.ScrollColumn = 44
ActiveWindow.ScrollColumn = 42
ActiveWindow.ScrollColumn = 41
ActiveWindow.ScrollColumn = 39
ActiveWindow.ScrollColumn = 37
ActiveWindow.ScrollColumn = 35
ActiveWindow.ScrollColumn = 33
ActiveWindow.ScrollColumn = 31
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 164
ActiveWindow.ScrollRow = 163
ActiveWindow.ScrollRow = 162
ActiveWindow.ScrollRow = 161
ActiveWindow.ScrollRow = 159
ActiveWindow.ScrollRow = 158
ActiveWindow.ScrollRow = 156
ActiveWindow.ScrollRow = 153
ActiveWindow.ScrollRow = 150
ActiveWindow.ScrollRow = 147
ActiveWindow.ScrollRow = 144
ActiveWindow.ScrollRow = 141
ActiveWindow.ScrollRow = 137
ActiveWindow.ScrollRow = 134
ActiveWindow.ScrollRow = 130
ActiveWindow.ScrollRow = 127
ActiveWindow.ScrollRow = 124
ActiveWindow.ScrollRow = 121
ActiveWindow.ScrollRow = 118
ActiveWindow.ScrollRow = 115
ActiveWindow.ScrollRow = 112
ActiveWindow.ScrollRow = 109
ActiveWindow.ScrollRow = 106
ActiveWindow.ScrollRow = 103
ActiveWindow.ScrollRow = 100
ActiveWindow.ScrollRow = 96
ActiveWindow.ScrollRow = 92
ActiveWindow.ScrollRow = 88
ActiveWindow.ScrollRow = 84
ActiveWindow.ScrollRow = 79
ActiveWindow.ScrollRow = 75
ActiveWindow.ScrollRow = 70
ActiveWindow.ScrollRow = 66
ActiveWindow.ScrollRow = 61
ActiveWindow.ScrollRow = 57
ActiveWindow.ScrollRow = 52
ActiveWindow.ScrollRow = 47
ActiveWindow.ScrollRow = 42
ActiveWindow.ScrollRow = 39
ActiveWindow.ScrollRow = 34
ActiveWindow.ScrollRow = 30
ActiveWindow.ScrollRow = 27
ActiveWindow.ScrollRow = 24
ActiveWindow.ScrollRow = 22
ActiveWindow.ScrollRow = 20
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Columns("J:J").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks _
:=False, Transpose:=False
End Sub

I know its not efficient because of the scrolling - but speed isnt an issue, the most lines this extract will contain is 200 rows....I wanted to hide the copy of 1000 from a cell - I'm not really up on VBA stuff...

In order to add the tax inclusive amount I used the following macro

Sub Add_GSTinc_in_N()
'
' Add_GSTinc_in_N Macro
' Macro recorded 12/04/2005
'

'
Range("N1").Select
ActiveCell.FormulaR1C1 = "=RC[-4]+((RC[-4]/100)*12.5)"
Range("N1:N346").Select
ActiveWindow.SmallScroll Down:=-111
ActiveWindow.ScrollRow = 137
ActiveWindow.ScrollRow = 1
Columns("N:N").Select
Selection.FillDown
End Sub

Which works well aside from the fact that it fills down for infinity....

-Separate invoices with blank rows between items

Sub Insert_Columns()
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
Cells(i, 1).EntireRow.Insert
Next
End Sub

Which is fine, but offers not facility to group items based on thier branch number. This means that each item will appear on a separate invoice - not much use, but a step there.

SO! If you have made it this far Here is what I would like help with.

Primarily

1. How would I go about sorting the data based on the branch ID? This would effectively group all sales into invoices for each branch.

2. Once sorted, I would need to separate each branch group with a blank row. This is to tell the accounting software to move on to a new invoice.

Secondarily

1. How can I stop a fill down process at the end of the data? Without a mechanism to stop it, when I fill down the price including tax column, it will carry on beyond the data. Since each month the data extract will be different (be longer, shorter) I cant reference hard x,y points. I need a dynamic way to establish the data has ended, and so the fill should end there also. This problem also effects the fill-down I use to achieve the cost+tax figure.

2. What would be the best way to merge all these macros together to achieve all tasks in one go?

If you can help with any side to this problem, then your thoughts would be most appreciated. Even guessing is helping me, as I will continue to try and nut it out on my own - ideas from the crowd could be just as helpful as a full on solution.

Thanks in advance

~Keef

Good morning/afternoon/evening,

I have written code to manipulate some work data that worked perfectly when running the macro once for each row of data. With multiple lines of data though I wanted a loop so the macro processes all rows each time it's run. Since I've added a 'Do.... Loop' command however it keeps picking up the wrong data and I cannot figure out why.

Here is the code:

Sub Step_02()

Dim outputText As String
Const delim = " "

    Application.ScreenUpdating = False

Do

'   Select A1 and highlight down to the second non-empty cell

        Range("A1").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
   
    If ActiveCell.Value = "" Then       ' Tell code to exit loop as last row of data has been found.
        Exit Do
        
    Else                                ' Continue with formatting rows
        
        ActiveCell.Offset(-1, 4).Select
        Range(Selection, Selection.End(xlUp)).Select

'   Merge all rows into single cell

        On Error Resume Next
        
        For Each cell In Selection
        outputText = outputText & cell.Value & delim
        Next cell
        With Selection
        .Clear
        .Cells(1).Value = outputText
        .Merge
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = False
        End With
        
        Selection.UnMerge

'   Delimit Selection And Paste To Next Cell

        With Selection
        Selection.TextToColumns Destination:=ActiveCell.Offset(0, 1), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :="@", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
            1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
        End With

'   Delete leftover comments

        ActiveCell.ClearContents

'   Select all blank cells between comments and delete rows

        Range("A1").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(-1, 0).Select
        Range(Selection, Selection.End(xlUp).Offset(1, 0)).Select
        Selection.EntireRow.Delete
    
    End If

Loop        ' Loop concludes once last row of data has been found.

    Application.ScreenUpdating = True

End Sub
The attached file shows a sample of the data including the way it should look and the way it actually turns out. The main aim of the macro is to take the multiple rows of comments in Column E and move them into a single delimited row. For some reason the 'Do... Loop' somehow compounds the comments. It will make more sense once you've seen the attachment.

Any help will be appreciated.

Hi Guys,

Hopefully a quick question,

I currently have a spreadsheet I use for work which I use to prioritise work for my team,

I have a list of Job reference numbers, Job age, and agreed lead time with customers. (and some other miscellaneous info)

My team updates later cells in the row to explain what has been done to the job

Every day I get 3 reports (in spreadsheet format with all the columns in the same order) with all of the current outstanding jobs, I use my spreadsheet to sort into priority order.
As I am unable to finish all jobs in a single day, the next days report contains many duplicates from the previous day.

Using my initial spreadsheet (today's) I need a method (by tomorrow morning!) of importing the data from all of the reports I'll get.

Then I need to merge the duplicates without overwriting the blank cells in the report with the updates my team have already input for these jobs.

First of all is there a simple method for doing the import/merge within excel or am I looking at Macro/VBA territory?

Secondly, how do I make this happen?

any advice would be appreciated.

Thankyou

Hi

I hope someone can help, I just don't seem to be able to produce a macro that will work for the problem I have.

I have a macro that works great below:-

 
Sub MergeRows()
Dim LR As Long, Rw As Long
Dim delRNG As Range

ActiveSheet.Copy
Rows(1).WrapText = True
Rows(2).Font.Bold = True
 Selection.sort Key1:=Range("AO2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
LR = Range("A" & Rows.Count).End(xlUp).Row
Set delRNG = Range("A" & LR + 10)

For Rw = LR To 2 Step -1
    If Range("AO" & Rw) = Range("AO" & Rw - 1) Then
        Range("AT" & Rw - 1) = Range("AT" & Rw) & "/" & Range("AT"
& Rw - 1)
    
        Set delRNG = Union(Range("A" & Rw), delRNG)
    End If
Next Rw

delRNG.EntireRow.Delete xlShiftUp
ActiveSheet.Name = "Ship List"

Selection.sort Key1:=Range("AT2"), Order1:=xlAscending, Key2:=Range("BB2" _
        ), Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header _
        :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    
End Sub

Now I need to make some additions to this to make the following changes :-

1. Insert 5 columns at the start, in the header row call these (in this order)
Col A = Service Reference
Col B = Service
Col C = Service Enhancement
Col D = Service Format
Col E = Service Class

2. Every row (with existing data) in the sheet then needs to be populated with the following data:

Col A = 1
Col B = PK1
Col C = blank
Col D = P
Col e = 1st

3. I then need to merge the surname into the first name column so we have first name and last name together (cols P and Q)

4. In Col V I need it to If cell = United Kingdom make the cell blank but If cell = France, change to FR

5. For Col AD (weight) if col V is blank populate 750 but if Col V shows FR then populate 220

Iv'e been searching for answers for days and trying different options but I am completely stuck.

I have attached the raw data example sheet and an example of how the results should look also.

All help is appreciated.

Many thanks

Jon

I am having issues trying something new to me. I have two very large code codes, each do very similar things, in fact most of the code is the same. So to reduce the amount, I've been trying to break them into smaller sub routines and then calling the appropriate subs when required.

The issue I think I am having is in declaring public variables. I declare the variables as public above all other code, but I receive errors when trying to run the subs. The process I'm trying to achieve is the first sub fetches a file, copies certain data, and removes blank rows. the remaining processes clean, group, transpose, and do some calcs and then generate a corporate letter. It is the first process that varies, as there are several places and types of files to look at.

So the first sub is where the file name is obtained (dialog box - vFile). and I need to use this name in the later subs, but I'm worried that the data is being retained. Does it look ok?

Below is the code I receive errors on: (the procedures called are madeof of pieces of the code that follows below that. I can post if necessary.

Any help is appreciated.


	VB:
	
Public Fname, SBname, SBpath, NewName As String 
Public vFile As Variant 
 
Sub RFQFromBID() 
     '    Public Fname, SBname, SBpath, NewName As String
     '    Public vFile As Variant
     
    Run "GetBIDData" 
    Run "CleanJoistData" 
    Run "GroupJoistData" 
    Run "CreateRFQ" 
    Run "SaveRFQ" 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
This is the rather large chunk of code:

	VB:
	
 SandblastingRFQ_BID() 
     '
     ' This macro will pull data from the selected NMBS BID file
     ' written by Maxwell Cameron
     ' written for Canadian Joist & Deck Corporation
     ' written on January 31st, 2011
     
     '   |==========================================================|
     '   |   This section will open the selected BOM and extract the Joist information    |
     '   |==========================================================|
     
    Dim vFile As Variant 
    Dim a, b, c, d, e, s As Integer 
    Dim Fname, Sname, SBname, SBpath, NewName As String 
     
     '   a -
    b = 3 '   b - row position for data paste
     '   c - counter for sheet check and copy from BID
     '   d - row position for sort
    e = 0 '   e- column position for sort
     '   vFile - BID file to retrieve data from
     '   Fname - Save name for RFQ
     '   Sname - Sheet name to check and use if exists
     
     
     '   Bring in Open Dialog Box
    ChDrive "L" 
    ChDir "HS-DHGL109shareCanadian JoistBID Files" 
    vFile = Application.GetOpenFilename("Excel Files (*.xl*, " & "*.xl*", 1, "Select NMBS BID File to Open", "Open", False) 
     '   Exit on Cancel
    If TypeName(vFile) = "Boolean" Then 
        Exit Sub 
    End If 
     
     '   Open BID
    Workbooks.Open vFile 
    Fname = ActiveWorkbook.Name 
    SBpath = ActiveWorkbook.Path 
    SBname = SBpath & "" & Left(Fname, 4) & " SandBlast RFQ.xlsx" 
     
     '   For each J sheet, copy the data to RFQ worksheet
    For c = 1 To ActiveWorkbook.Sheets.Count 
        Sname = "J (" & c & ")" 
On Error Goto ErrHndlr: 
        Select Case True 
        Case Not Sheets(Sname) Is Nothing 
            Sheets(Sname).Range("A5:E41").Copy Destination:=ThisWorkbook.Sheets("Sheet6").Cells(b, 1) 
            b = b + 36 
        End Select 
    Next 
Label1: 
    On Error Goto 0 
    b = b + 1 
     '   Close BID File without Saving
    Workbooks(Fname).Close False 
     
    ThisWorkbook.Sheets("Sheet6").Activate 
     
     '   Delete Blank Rows, working backwards
    Range(Cells(3, 1), Cells(b, 5)).Select 
    For g = b To 1 Step -1 
        Select Case True 
        Case WorksheetFunction.CountA(Selection.Rows(g)) = 0 
            Selection.Rows(g).EntireRow.Delete 
Goto Label2: 
        Case Cells(g, 3) = "ALT" 
            e = 1 
Goto Label2: 
        End Select 
Label2: 
    Next g 
     
     '   sorts the data based on length and joist designation
    Range("E3").End(xlDown).Select 
    d = ActiveCell.Row 
    Range(Cells(3, 1), Cells(d, 5)).Select 
    ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Clear 
    ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Add Key:=Range(Cells(3, 4), Cells(d, 4)), SortOn:=xlSortOnValues,
Order:=xlAscending, DataOption:=xlSortNormal 
    ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Add Key:=Range(Cells(3, 5), Cells(d, 5)), SortOn:=xlSortOnValues,
Order:=xlAscending, DataOption:=xlSortNormal 
    ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Add Key:=Range(Cells(3, 3), Cells(d, 3)), SortOn:=xlSortOnValues,
Order:=xlAscending, DataOption:=xlSortNormal 
    With ActiveWorkbook.Worksheets("Sheet6").Sort 
        .SetRange Range(Cells(3, 1), Cells(d, 6)) 
        .Header = xlGuess 
        .MatchCase = False 
        .Orientation = xlTopToBottom 
        .SortMethod = xlPinYin 
        .Apply 
    End With 
    Select Case True 
    Case Not e = 0 
        e = d + 2 
        Cells(e, 5).End(xlDown).Select 
        s = ActiveCell.Row 
        Range(Cells(e, 1), Cells(s, 5)).Select 
        ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Clear 
        ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Add Key:=Range(Cells(e, 4), Cells(s, 4)), SortOn:=xlSortOnValues,
Order:=xlAscending, DataOption:=xlSortNormal 
        ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Add Key:=Range(Cells(e, 5), Cells(s, 5)), SortOn:=xlSortOnValues,
Order:=xlAscending, DataOption:=xlSortNormal 
        ActiveWorkbook.Worksheets("Sheet6").Sort.SortFields.Add Key:=Range(Cells(e, 3), Cells(s, 3)), SortOn:=xlSortOnValues,
Order:=xlAscending, DataOption:=xlSortNormal 
        With ActiveWorkbook.Worksheets("Sheet6").Sort 
            .SetRange Range(Cells(e, 1), Cells(s, 6)) 
            .Header = xlGuess 
            .MatchCase = False 
            .Orientation = xlTopToBottom 
            .SortMethod = xlPinYin 
            .Apply 
        End With 
    End Select 
     
     
     
     '
     ' End of section
     '
ErrHndlr: 
    If c = ActiveWorkbook.Sheets.Count Then 
Resume Label1: 
    End If 
    If Err.Number = 9 Then 
        c = c + 1 
        Sname = "J (" & c & ")" 
        Resume 
    End If 
     
     
     
     '   |=============================================|
     '   |   This section will clean the extracted the Joist information  |
     '   |=============================================|
     
    Dim l, h, f As Integer 
    Dim i, j, k As Double 
     
     '   l - len value base on joist designation
     '   h - last row of entries
     '   f - counter for "for" procedure
     '   i - inch value for joist length
     '   j - decimal foot length of joist - calc'd
     '   k - foot value for joist length
     
     
     'select joist designations
    Sheets("Sheet6").Activate 
    Range("C3").End(xlDown).Select 
    h = ActiveCell.Row 
     
     'trim loads off designation
    Range(Cells(1, 3), Cells(h, 3)).Select 
    For f = 3 To Selection.Rows.Count 
         'find joist prefix
        Select Case True 
        Case Mid(Cells(f, 3), 2, 1) = "K" 
            l = 2 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Mid(Cells(f, 3), 2, 1) = "k" 
            l = 2 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Mid(Cells(f, 3), 3, 1) = "K" 
            l = 3 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Mid(Cells(f, 3), 3, 1) = "k" 
            l = 3 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Mid(Cells(f, 3), 3, 1) = "L" 
            l = 4 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Mid(Cells(f, 3), 3, 1) = "l" 
            l = 4 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Mid(Cells(f, 3), 3, 1) = "D" 
            l = 5 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Mid(Cells(f, 3), 3, 1) = "d" 
            l = 5 
            Cells(f, 7) = Left(Cells(f, 3), l) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        Case Else 
            Cells(f, 7) = Cells(f, 3) 
            k = Cells(f, 4) 
            i = Cells(f, 5) 
            j = k + (i / 12) 
            Cells(f, 6) = j 
        End Select 
    Next 
     
    Range(Cells(3, 7), Cells(h, 7)).Copy Destination:=Range(Cells(3, 3), Cells(h, 3)) 
    Range(Cells(1, 7), Cells(h, 7)).ClearContents 
    Range(Cells(1, 1), Cells(h, 6)).Select 
    With Selection.Font 
        .Name = "Calibri" 
        .Strikethrough = False 
        .Superscript = False 
        .Subscript = False 
        .OutlineFont = False 
        .Shadow = False 
        .Underline = xlUnderlineStyleNone 
        .ColorIndex = xlAutomatic 
        .TintAndShade = 0 
        .ThemeFont = xlThemeFontMinor 
    End With 
    With Selection 
        .HorizontalAlignment = xlCenter 
        .VerticalAlignment = xlCenter 
        .WrapText = False 
        .Orientation = 0 
        .AddIndent = False 
        .IndentLevel = 0 
        .ShrinkToFit = False 
        .ReadingOrder = xlContext 
        .MergeCells = False 
    End With 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone 
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone 
    With Selection.Borders(xlEdgeLeft) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlThin 
    End With 
    With Selection.Borders(xlEdgeTop) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlThin 
    End With 
    With Selection.Borders(xlEdgeBottom) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlThin 
    End With 
    With Selection.Borders(xlEdgeRight) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlThin 
    End With 
    With Selection.Borders(xlInsideVertical) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlThin 
    End With 
    With Selection.Borders(xlInsideHorizontal) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlThin 
    End With 
     
     'Remove unneccessary headers
    Sheets("Sheet6").Activate 
    Range("C3").End(xlDown).Select 
    h = ActiveCell.Row 
    f = 0 
    For f = h To 3 Step -1 
        Range(Cells(f, 1), Cells(f, 6)).Select 
        Select Case True 
        Case Cells(f, 6) = 0 
            Select Case False 
            Case Cells(f, 3) = "ALT" 
                Selection.EntireRow.Delete 
                 ' f = f - 1
                 ' t = t - 1
            End Select 
        End Select 
    Next f 
     
     
     
     '==================
     '
     ' End of section
     '
     
     
     '   |====================================================|
     '   |   This section will group relevant data and calculate data for quote   |
     '   |====================================================|
     
    Dim m, n, o, p, q, altflag, altrow As Integer 
     
     '   m - cummulative value for joist quantity
     '   n - value of bottom row
     '   o - value of row for RFQ worksheet
     '   p - counter for "for" procedure
     '   q - p + 1
     
    m = Cells(3, 2).Value 
     
    Range("C3").End(xlDown).Select 
    n = ActiveCell.Row 
    o = 3 
    Range(Cells(1, 2), Cells(n, 6)).Select 
     
    For p = 3 To Selection.Rows.Count 
        q = p + 1 
         
        Select Case True 
        Case Cells(p, 6).Value = Cells(q, 6) 'Check if next line is same length
            Select Case True 
            Case Cells(p, 3).Value = Cells(q, 3).Value 'Check if next line is same joist
                m = m + Cells(q, 2).Value 'Add Qty of next line
            Case Else 
                Cells(o, 8) = m 'Qty
                Cells(o, 9) = Cells(p, 3) 'Designation
                Cells(o, 10) = Cells(p, 6) 'Length/Joist
                Cells(o, 11) = "=RC[-1]*RC[-3]" 'Total Length
                Cells(o, 12) = "=ceiling((RC[-1]*RC[-4]*vlookup(RC[-3],mass,2,false))/2000,1)" 'Total Weight rounded to next
ton
                Cells(o, 13) = Left(Cells(p, 3), 2) & "''" 'Joist Depth"
                Range(Cells(o, 10), Cells(o, 11)).NumberFormat = "0.00" 
                Range(Cells(o, 8), Cells(o, 13)).VerticalAlignment = xlCenter 
                Range(Cells(o, 8), Cells(o, 13)).HorizontalAlignment = xlCenter 
                o = o + 1 'Output Next Cell
                m = Cells(q, 2) 'Reset Qty Counter
            End Select 
        Case Cells(p, 3) = "ALT" 
            Range(Cells(o, 9), Cells(o, 10)).Merge 
            Cells(o, 9) = "Alternate Price for Below" 
            Cells(o, 9).VerticalAlignment = xlCenter 
            Cells(o, 9).HorizontalAlignment = xlLeft 
            o = o + 1 'Output Next Cell
            m = Cells(q, 2) 'Reset Qty Counter
            altflag = 1 'trigger for sort
            altrow = o '1st row of alt section
        Case Else 
            Select Case Left(Cells(p, 3), 1) 
            Case 1 To 9 
                Cells(o, 8) = m 'Qty
                Cells(o, 9) = Cells(p, 3) 'Designation
                Cells(o, 10) = Cells(p, 6) 'Length/Joist
                Cells(o, 11) = "=RC[-1]*RC[-3]" 'Total Length
                Cells(o, 12) = "=ceiling((RC[-1]*RC[-4]*vlookup(RC[-3],mass,2,false))/2000,1)" 'Total Weight rounded to next
ton
                Cells(o, 13) = Left(Cells(p, 3), 2) & "''" 'Joist Depth"
                Range(Cells(o, 10), Cells(o, 11)).NumberFormat = "0.00" 
                Range(Cells(o, 8), Cells(o, 13)).VerticalAlignment = xlCenter 
                Range(Cells(o, 8), Cells(o, 13)).HorizontalAlignment = xlCenter 
                o = o + 1 'Output Next Cell
                m = Cells(q, 2) 'Reset Qty Counter
            Case Else 
                m = Cells(q, 2) 'Reset Qty Counter
            End Select 
        End Select 
        Select Case True 
        Case Application.WorksheetFunction.IsNA(Cells(o - 1, 12)) 
            Range(Cells(o - 1, 12), Cells(o - 1, 13)).Select 
            With Selection 
                .ClearContents 
                .Merge 
            End With 
            Cells(o - 1, 12) = "Check Joist Type -Rerun" 
        End Select 
    Next 
     '
     ' End of section
     '
     
     '   |==========================================|
     '   |   This section will create the RFQ and prompt to Save   |
     '   |==========================================|
     
    Dim r As Integer 
     '   r - row value for bottom row
     
    Sheets("Sheet6").Activate 
    Range("I3").End(xlDown).Select 
    r = ActiveCell.Row 
     
    Range(Cells(3, 8), Cells(r, 13)).Copy Destination:=Sheets(1).Range("A9") 
    Sheets("RFQ").Select 
    Range("D3") = "BID #" & Left(Fname, 4) 
    Range("B9").End(xlDown).Select 
    r = ActiveCell.Row 
    Range(Cells(9, 1), Cells(r, 6)).Select 
     
    With Selection.Font 
        .Name = "Verdana" 
        .Size = 12 
        .Strikethrough = False 
        .Superscript = False 
        .Subscript = False 
        .OutlineFont = False 
        .Shadow = False 
        .Underline = xlUnderlineStyleNone 
        .ColorIndex = xlAutomatic 
        .TintAndShade = 0 
        .ThemeFont = xlThemeFontMinor 
    End With 
    With Selection 
        .HorizontalAlignment = xlCenter 
        .VerticalAlignment = xlCenter 
        .WrapText = False 
        .Orientation = 0 
        .AddIndent = False 
        .IndentLevel = 0 
        .ShrinkToFit = False 
        .ReadingOrder = xlContext 
        .MergeCells = False 
    End With 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone 
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone 
    With Selection.Borders(xlEdgeLeft) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlMedium 
    End With 
    With Selection.Borders(xlEdgeTop) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlMedium 
    End With 
    With Selection.Borders(xlEdgeBottom) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlMedium 
    End With 
    With Selection.Borders(xlEdgeRight) 
        .LineStyle = xlContinuous 
        .ColorIndex = 0 
        .TintAndShade = 0 
        .Weight = xlMedium 
    End With 
    With Selection.Borders(xlInsideVertical) 
        .LineStyle = xlContinuous 
        .ThemeColor = 2 
        .TintAndShade = 0.499984740745262 
        .Weight = xlThin 
    End With 
    With Selection.Borders(xlInsideHorizontal) 
        .LineStyle = xlContinuous 
        .ThemeColor = 2 
        .TintAndShade = 0.499984740745262 
        .Weight = xlThin 
    End With 
    For s = 9 To r 
        If Cells(s, 5) = "Check Joist Type -Rerun" Then 
            Range(Cells(s, 5), Cells(s, 6)).Select 
            With Selection 
                .Merge 
            End With 
        End If 
    Next 
     
     '
     ' End of section
     '
     'Range("J1") = SBpath
     
     '   |===================================|
     '   |   This section will open the save dialog box     |
     '   |===================================|
     
    With Application 
        .DisplayAlerts = False 
         
        NewName = Application.GetSaveAsFilename(SBname) ', FileFilter:="Excel Workbook (*.xlsx), *.xlsx"
        If TypeName(SBname) = "Boolean" Then 
            Exit Sub 
        End If 
        ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=51 
    End With 
     '
     ' End of section
     '
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I need to consolidate rows to make a mailing for customers. I imported a list of customers and their information from quickbooks that was a report and need to send a personalized letter to each customer. Using the mail merge feature i can do this but I need each customers information to be in one row.
Example
Currently
Row 1 is Header row
A B C D Ect. Till Row Q.
1. Customer name /Type/ date /etc..till row Q with Balance.
2. John Smith /All other rows are blank.
3. Blank Cell / Sales Receipt/1/16/06/ till row Q
4. Total John Smith /All rows blank till Row Q has the total for the number of sales receipts.

What I need to make the letters is all John Smiths information to be in one row where I can select the columns in word to insert information into the letter. So It needs to be:
A B C D R
1. Customer Name /Type/ date/Etc... /Type from row 3 etc.
2. John Smith /All Rows Should be blank till Col. R/Sales Receipt/Etc.
3. Jane Doe /All Rows Should be Blank till Col. R/Sales Receipt/Etc.
4. Jack Johnson /All Rows Should be Blank Till Col. R/Sales Receipt/Etc.

So Each row will create one letter for each Customer.
Not All customers have just one sales receipt. Some have multiple receipts in which every Receipt has its own row. So lets say jane Doe has 3 Receipts.
Ex. A B C D Till Q
5. Jane Doe /All Rows Blank
6. /Sales Receipt/ 1/16/06/Etc. /$50.00
7. /Sales Receipt/ 1/17/06/Etc. /$100.00
8. /Sales Receipt/ 1/18/06/Etc. /$150.00
9.Total Jane Doe /All Rows Blank till Q. /$150.00
So I need all Jane Doe information to be on one row So I can mail Merge all three of her Sales receipts into one letter with a total of her sales.

Any Macro or VBA would be great as i have a list of 1700 rows which is probably about 500 customers when consolodated to one row per customer. Thanks

Hi - I am hiding column ranges on a worksheet and of 14 used 13 are accurate, but when I try to hide column range BD:BG it always hides column BH as well. Selectively unhiding column BH then unhides column BG as well.
Just hiding column just BG hides BH as well.

On a blank worksheet there is no problem, so it is something to do with the copied sheet. As far as I can see there are no merged cells to cause the problem, and there is nothing special about column BH, but it seems irreversibly associated with column BG.

Am at a loss to know the cause - hope you have some ideas

Many Thanks


	VB:
	
 TotalsSheet1() 
     '
     ' TotalsSheet1 Macro
     ' Macro recorded 24/01/2005 by Denise Bowes
     '
     
     ' Turn off Screen Updates
    Application.ScreenUpdating = False 
     
    Sheets("Sheet1").Select 
    Sheets("Sheet1").Copy After:=Sheets(3) 
     
    ActiveSheet.Unprotect Password:="fredbloggs" 
     
    Rows("112:113").Select 
    Selection.Copy 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
     
    Rows("1:4").Select 
    Selection.UnMerge 
     
    Rows("98:108").Select 
    Selection.UnMerge 
     
     '  Hide Columns not wanted (all OK except BD:BG)
     
     '
    Columns("C:F").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("H:K").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("M:P").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("R:U").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("W:Z").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("AB:AE").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("AG:AJ").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("AO:AR").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("AT:AW").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("AY:BB").Select 
    Selection.EntireColumn.Hidden = True 
     
    ‘Range causing problem – selects comns BD:BH instead 
    Columns("BD:BG").Select 
    Selection.EntireColumn.Hidden = True 
    ‘OK 
    Columns("BI:BL").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("BN:BQ").Select 
    Selection.EntireColumn.Hidden = True 
    Columns("BS:BV").Select 
    Selection.EntireColumn.Hidden = True 
    Range("$A$1").Select 
     
     ' ......

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I desperately need a macro to do the following: I have a list of duplicate entries in column A but the other columns may not be duplicates. I want to merge the two (or more) rows of duplicate entries – that is to transfer all the information into one row (since there can be blank entries in one and non blank entries in another.

Also if there are rows with different values in the corresponding cells, then to put the values of the two (or more) cells together i.e. if A5=A6=A7 and if C5 has “xx” and C6 has “yy” and C7 has “zz”, then C5 would read “xx~~yy~~zz” – and I want the values to maintain their colour in the cell (i.e. if xx is blue and yy is red and zz is green, then it would still keep the same colour in the merged cell (ideally the ~~ to be black)

The area for this do be done is A4:BQ3040

Would really appreciate any help on the matter since this is really important stuff for me to get done.

I am trying to develop a macro to build formulas on a second sheet from data in cells of the first sheet.
There are header rows written into merged cells which I need to read and save their addresses.
By making a range that is wide enough to span the widths of the merged cells, I can find the headers, but for some reason, it returns the second, third, fourth, etc. occurrences before looping back to the top to find the actual first occurrence.
Since I really need these to maintain their order, this is not acceptable.
My search string is "CATEGORY ?00" to find all cells that have CATEGORY 100, CATEGORY 200, ..., CATEGORY 900 which is in the merged cells of columns A-J. They start at $A$1:$J$1, but my routine always returns that address as the last address.
I did one test where I inserted a blank row as the first row in the sheet, but since I am trying to work with a previously created "family" of spreadsheets, I would rather get this working with the sheets as is.
Not to mention understanding why I cannot get this to function as I expect or understand the logic in the code.
Thanks.


No luck finding an answer? You could always try Google.