Excel Macro for Selected Area Concatenation - excel

I was hoping someone would have some insight as to how to approach the following Excel macro requirement.
Starting condition:
Variable number of text values in Column A.
Proposed solution:
I would like to be able to select a variable number of consecutive cells in column A, and then have the text concatenated, separated by a comma and , into a single column adjacent to the top most cell in column B.
Examples:
A2-A4 would be selected on the sheet.
After running the macro, the contents of B2 (Directly adjacent to top of selection) would contain text in the form "A2, A3, A4".
A5-A10 selected:
After running the macro, the contents of B5 (Directly adjacent to top of selection) would contain text in the form "A5, A6, A7, A8, A9, A10".
What is killing me is how to utilize the variablity of multiple selections and additonally, I'm not clear on how to handle looping in Excel macro's. I have a CS degree but I ended up working in Infrastructure so I'm a bit rusty. Is someone could help, this would save me emmense time everyday. Thanks to any responses.

The following code does what you seek. I have not added many comments because I am not sure what level of comments are appropriate. For example, I do not want to explain the purpose of each statement if your CS degree allows you to guess. I also suspect there is more to your question than the obvious. For example, should I have made this a function with the worksheet and row numbers passed as parameters. Please come back with questions and I will improve my answer as necessary.
Option Explicit
Sub JoinCells()
Dim ColFirst As Long
Dim ColLast As Long
Dim JoinedValue As String
Dim RowCrnt As Long
Dim RowFirst As Long
Dim RowLast As Long
RowFirst = Selection.Row ' First row of selection
' Selection.Rows.Count returns the number of rows in the selection.
' Warning! You can fool this code by making multiple selections.
RowLast = RowFirst + Selection.Rows.Count - 1
ColFirst = Selection.Column
ColLast = ColFirst + Selection.Columns.Count - 1
If ColFirst <> 1 Or ColLast <> 1 Then
Call MsgBox("Please select a range within column ""A""", vbOKOnly)
Exit Sub
End If
With Worksheets("xxxxxxx") ' Worksheet of your choice.
JoinedValue = .Cells(RowFirst, "A").Value
For RowCrnt = RowFirst + 1 To RowLast
JoinedValue = JoinedValue & "," & .Cells(RowCrnt, "A").Value
Next
.Cells(RowFirst, "B").Value = JoinedValue
End With
End Sub

Related

How to combine three columns into one and leave out empty cells?

Hello I need to advice some formulas on my problem:
How can I combine two, three or more columns into single one column?
And if in columns are "empty" cells I want to skip these cells inside of that single one column.
But be aware! This is the problem. All columns are contains another formulas. So these "empty" cells are in fact contains my another formulas with result ="".
Here is example of what I want to get - in column E:
EDIT:
New functions like TOCOL are not available in my Microsoft Office 365 MSO: 16.0.14326.21092 (32 bit).
You can use:
Formula in E2:
=TOCOL(IF(A2:C10="",NA(),A2:C10),3,1)
Note that just =TOCOL(A2:C10,3,1) is not going to cut it if these cells hold an empty string "".
If your data is not very huge use:
=FILTERXML("<t><s>"&TEXTJOIN("</s><s>",1,TRANSPOSE(A2:C10))&"</s></t>","//s")
With VBA:
Option Explicit
Sub To_Col()
Dim lngR As Long, lngC As Long, varV, lngRow As Long, lngCol As Long
varV = [A2:C10]
With ActiveCell
lngRow = .Row
lngCol = .Column
End With
For lngC = 1 To UBound(varV, 2)
For lngR = 1 To UBound(varV)
If varV(lngR, lngC) <> "" Then
Cells(lngRow, lngCol).Value = varV(lngR, lngC)
lngRow = lngRow + 1
End If
Next lngR
Next lngC
End Sub
place in E2 and launch macro, change [A2:C10] with your real range

Fill an array with rows that do not meet specific criteria and preserve hyperlink formulas

I have a sheet with 32 columns of data, starting in row 2 to LastRow. The first row is a header row. Several columns contain hyperlink formulas (“D”,”F”,”R”,”S”,”X”,”Z” and “AA”), other columns contain general values. I would like to populate an array with rows that don’t include specific values in column D. Those values are part of a hyperlink formula. For example, in D3 there is =HYPERLINK("http://www.uniprot.org/uniprot/P35222"," CTNNB1"), I’m filtering based on the values inside the second set of quotation marks “CTNNB1”. I would like to output this array on a new sheet. The code bellow runs but it doesn’t output any data. The code includes comments to explain steps and issues. Please help me fix the code or suggest something that will work. Thank you very much in advance.
Once the rows that meet the criteria are identified, how do I create an array row by row and how to correctly output it on a Sheet “Access”?
Sub aa()
Dim CellValue As Variant
Dim CellFormula As String
Dim CellPart() As String
Dim CellValueRow As Long
Dim CellValueCol As Long
Dim ColCrnt As Long
Dim ColLast As Long
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("all") ' Replaced with name of your worksheet
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
ReDim CellValue(1 To RowLast - 1, 1 To ColLast) 'max # of array rows based on last row of data available
CellValueRow = 1
For RowCrnt = 2 To RowLast
CellFormula = .Cells(RowCrnt, "D").Formula
If Left(CellFormula, 11) = "=HYPERLINK(" Then
CellFormula = Mid(CellFormula, 12) '=> "http://www.uniprot.org/uniprot/P42336","PIK3CA")
CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1) '=> "http://www.uniprot.org/uniprot/P42336","PIK3CA"
CellFormula = Replace(CellFormula, """", "") '=> http://www.uniprot.org/uniprot/P42336,PIK3CA
CellPart = Split(CellFormula, ",")
'Debug.Print CellPart(0) & " " & CellPart(1)
If CellPart(1) <> "Q61R" And CellPart(1) <> "I391M" And CellPart(1) <> "V600E" And _
CellPart(1) <> "PIC3CA" And CellPart(1) <> "BRAF" And CellPart(1) <> "EGFR" Then
CellValue(CellValueRow, ) = .Range(.Cells(RowCrnt, 1), .Cells(RowCrnt, ColLast)).Formula '===> need help here
CellValueRow = CellValueRow + 1
End If
End If
Next
'For RowCrnt = 1 To 10
'For ColCrnt = 1 To 10
'Debug.Print "[R" & RowCrnt & "C" & ColCrnt & "]" & CellValue(RowCrnt, ColCrnt);
'Next
'Debug.Print
'Next
End With
Worksheets("Access").Range("A2:AF" & RowLast).Value = Application.Index(CellValue, 0)
End Sub
Issue 1
Dim i, j, k, m, LastRow, openPos, closePos As Integer 'As Long
This declares i, j, k to openPos as Variants and only closePos as an Integer, If you list several variables in one Dim statement, you must give each one its own type.
Do not use type Integer. With VBA, “Integer” declares a 16-bit integer which requires special processing on 32-bit or 64-bit computers. Long is now the recommended type.
I rarely place several variables in a single Dim statement. It saves a little typing but I prefer to declare my variables one per line in alphabetic sequence.
Please do not declare variables with names like i, j and k. If this is a “quick write” macro that will then be discarded, names probably do not matter too much. However, if you might return to this macro in six months, will you remember what i, j and k are? Meaningful names take longer to type but make your code so much easier to read and understand.
Issue 2
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
The active worksheet is the default worksheet so specifying its use does not serve much purpose.
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
would give exactly the same effect.
However I would prefer you write With Worksheets(“xxxx”). If you use the active worksheet, you are relying on the user having the required worksheet open when they start the macro. If you return to this macro in six months, will you remember which worksheet is the required worksheet? Sheets.Add makes the new sheet the active worksheet. Your code can get very confusing if you have to remember which sheet is the active sheet.
Issue 3
ReDim Result(LastRow - 1)
The format for subscripts is: [Lower To] Upper.
If you omit “[Lower To]”, the value of the Option Base statement determines the value of the lower bound. I do not recall ever seeing the Option Base statement but I still prefer being explicit. VBA is unusual in allowing you to have different lower bounds; for most languages it is fixed as zero. With VBA I can write: ReDim Result(2 To LastRow). I always set my lower bounds to what every value I find most helpful at the time.
If VBA creates an array (for example with Split), that array will almost always have a lower bound of zero. The only exception I can think of is when you copy a range to a Variant. Here the resultant array has lower bounds of one.
You set Result to one dimension but use it as two dimensional array. I think you want:
ReDim Result(1 To LastRow-1, 1 To 27)
Issue 4
On Error Resume Next
You should only use this statement like this:
On Error Resume Next
Statement that might fail
On Error GoTo 0
If Err.Number > 0 Then
Test or display Err.Number or Err.Description
End If
You should only use On Error when you cannot avoid Excel encountering an error. For example, when opening a file for which you might not have read permission. In this situation, On Error allows you to provide the user with a helpful message or perhaps recover by trying a different file. You do not use it to avoid arithmetic errors.
Issue 5
If Application.ReferenceStyle = xlR1C1 Then
Str = .Cells(i, 4).FormulaR1C1
Else
Str = .Cells(i, 4).Formula
End If
Application.ReferenceStyle affects how formulae are displayed. A VBA macro can request either style. Pick the formula style you prefer although a hyperlink should not be affected by your choice.
Issue 6
Before you can extract the display text from a hyperlink formula you must check the cell contains a hyperlink formula. This macro uses a different technique although there is nothing wrong with searching for the last two double quotes in the formula. With this technique, the value you seek is in CellPart(1).
Option Explicit
Sub Demo()
Dim CellFormula As String
Dim CellPart() As String
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("Data") ‘ Replace with the name of your worksheet
RowLast = .Cells(Rows.Count, "D").End(xlUp).Row
For RowCrnt = 2 To RowLast
CellFormula = .Cells(RowCrnt, "D").Formula
If Left(CellFormula, 11) = "=HYPERLINK(" Then
' It is possible to make all these changes to CellFormula in one go
' but this is better for showing what I am doing
CellFormula = Mid(CellFormula, 12)
CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1)
CellFormula = Replace(CellFormula, """", "")
CellPart = Split(CellFormula, ",")
Debug.Print CellPart(0) & " " & CellPart(1)
End If
Next
End With
End Sub
**Issue 7 **
In your macro you are:
Scanning down column D looking for rows of interest.
Copying the cells of rows of interest to an array.
You do nothing with the final array but I assume you intended to write it to the new worksheet.
This technique involves moving every cell of interest individually from the worksheet to the array. This is not quite as slow as some people think but it is not in my view the easiest approach.
You have used LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row to find the last row containing data. VBA offers several methods of finding the last row and column and this is generally the easiest to use. However, none of the available methods works in every situation. This technique relies on the programmer knowing which column (or row) contains the most data.
I have used:
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
The first statement finds the last used cell in any column while the second finds the last used cell in any row. These statements do not rely on the programmer knowing which column has the last row or which row has the last column. They are also useful if your data is not rectangular.
In this macro, I have pulled every formula from every cell in the worksheet into an array in a single statement. I have then displayed the first ten rows and columns so you can see what I have imported.
Sub Demo2()
Dim CellValue As Variant
Dim ColCrnt As Long
Dim ColLast As Long
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("Data") ' Replace with the name of your worksheet
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
CellValue = .Range(.Cells(1, 1), .Cells(RowLast, ColLast)).Formula
For RowCrnt = 1 To 10
For ColCrnt = 1 To 10
Debug.Print "[R" & RowCrnt & "C" & ColCrnt & "]" & CellValue(RowCrnt, ColCrnt);
Next
Debug.Print
Next
End With
End Sub
You may need to increase my end values of 10 to see enough data but this macro demonstrates that I can download every value and formula in a worksheet into an array with a single statement.
I recommend creating little macros like mine that explore a single feature when you are unsure about that feature. The trouble with your complete macro is that you do not know where it has gone wrong. With a single feature macro there is nothing else to confuse the picture as you try different things you get it working. If you fail to get it working, a single feature macro will get an answer on Stack Overflow much more quickly than a confused, multi-feature macro.
Complete solution
Above I have explored how to access the data and how to make decisions about which rows are of interest. I think we are now ready to make final decisions.
There are several approaches and it is not obvious to me which would be the better.
For step 1, I believe importing the worksheet into an array and identifying interesting rows in memory is the best approach. The alternative, reading down column D within the worksheet, has no advantages that I can see.
For step 2, I can see three different approaches with a minor different to step 1:
Copy the entire worksheet to an array. Copy interesting rows to a different array. Copy the second array to a new worksheet.
Copy column D of the worksheet to an array. Use the array to identify interesting rows. Copy the interesting rows, as they are identified, from the original worksheet to a new worksheet.
Copy column D of the worksheet to an array. Use the array to identify interesting rows. Use Union to a single range containing all the interesting rows and copy them as a unit from the original worksheet to a new worksheet.
I have never tried approach 3 although I have done something similar by using AutoFilter to select rows and then copying the visible rows to a new location. However, I do not see that it offers anything over approach 2 and I have had problems with very large unions so I have ignored approach 3.
You can only copy values and formulae to an array so you will lose any formatting with approach 1. Approach 1 is probably faster than approach 2. Approach 2 looks as though it will be a little simpler to code.
Apart from the possible need to preserve formatting, I cannot see a major advantage for either approach. Since formatting might be important for this or a similar project, I have decided to go for approach 2.
It is not relevant for approach 2, but you say you do not know how to ReDim Preserve Result to remove the unused rows. The answer is you cannot remove these rows conveniently but it does not matter. You can only use ReDim Preserve to change the size of the last dimension of an array. An array read from a worksheet or being prepared for writing to a worksheet has the worksheet columns as the second dimension. You could use the worksheet function Transpose to switch the dimensions, ReDim the array and then Transpose back. However, I have found that some (perhaps all) worksheet functions are very slow. A transpose coded in VBA is faster than the Excel version. The worksheet functions seem perfectly adequate when called from the keyboard, so the slowness is probably an overhead of the interface. However, when writing an array to a worksheet, unused trailing rows do not matter except possibly if they might overwrite rows you wish to keep.
The following is my attempt at your macro. I do not have much suitable test data but it appears to work as required.
Sub NewAa()
' Change these names as required
Const WshtSrcName As String = "Data"
Const WshtExtName As String = "Extract"
Dim CellFormula As String
Dim CellPart() As String
Dim CellValue As Variant
Dim Found As Boolean
Dim InxNTBE
Dim NotToBeExtracted() As Variant
Dim RowExtCrnt As Long
Dim RowSrcCrnt As Long
Dim RowSrcLast As Long
Dim WshtSrc As Worksheet
Dim WshtExt As Worksheet
' If you are going to be extracting different hyperlinks, an array is easier
' to amend than an If statement
NotToBeExtracted = Array("Q61R", "I391M", "V600E", "PIC3CA", "BRAF", "EGFR")
Set WshtSrc = Worksheets(WshtSrcName)
Worksheets.Add After:=Worksheets(Worksheets.Count)
' The new worksheet is now the active worksheet
ActiveSheet.Name = WshtExtName
Set WshtExt = ActiveSheet
With WshtSrc
RowSrcLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
' Import column D
CellValue = .Range(.Cells(1, "D"), .Cells(RowSrcLast, "D")).Formula
' CellValue will be an array with dimensions (1 To RowLast, 1 to 1).
' Note the lower bounds for such arrays are always one even when column 4 has been imported.
End With
' Copy header row
WshtSrc.Rows(1).Copy Destination:=WshtExt.Cells(1, 1)
' Note the format of copy range is: Xxxxx.Copy Destination:=Yyyyy
' where:
' Xxxxx is the range to be copied
' Yyyyy is the top left cell of the destination range
' "Destination:=" is optional but think it add clarity.
RowExtCrnt = 2
For RowSrcCrnt = 2 To RowSrcLast
CellFormula = CellValue(RowSrcCrnt, 1)
If Left(CellFormula, 11) = "=HYPERLINK(" Then
' Format is: =HYPERLINK("Xxxx","Yyyy")
' Extract Yyyy to CellPart(1)
CellFormula = Mid(CellFormula, 12)
CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1)
CellFormula = Replace(CellFormula, """", "")
CellPart = Split(CellFormula, ",")
' Attempt to match CellFormula against one of the hyperlink texts
' that are not to be extracted
Found = False
For InxNTBE = LBound(NotToBeExtracted) To UBound(NotToBeExtracted)
If CellPart(1) = NotToBeExtracted(InxNTBE) Then
Found = True
Exit For
End If
Next
If Not Found Then
' This hyperlink is to be extarcted
WshtSrc.Rows(RowSrcCrnt).Copy Destination:=WshtExt.Cells(RowExtCrnt, 1)
RowExtCrnt = RowExtCrnt + 1
End If
End If
Next
End Sub

splitting a string text into separate rows in VBA

I have 2 text boxes in a excel (or csv file) as below:
text box 1 contains (#11111,#22222,#33333), text box 2 contains (#55555)
#11111,#22222,#33333 #55555
I want the text between , to be on 3 different rows and repeat the text in 2nd text box so that it looks like below:
#11111 #55555
#22222 #55555
#33333 #55555
I am new to VBA. I am reading about string functions but I can't come up with logic on how to do it.
Any help would be appreciated.
Hi #tim williams - Thanks for the advice. I did manage to write a short code which accomplishes the task but it overwrites the text if I have any in 2nd row and 3rd row.
Sub splitcells()
Dim txt As String
Dim txt2 As String
Dim i As Integer
Dim cell1 As Variant
txt = Range("a1", "A1").Value
cell1 = Split(txt, ",")
For i = 0 To UBound(cell1)
Cells(i + 1, 1).Value = cell1(i)
Next i
txt2 = Range("b1", "b1")
For i = 1 To UBound(cell1)
Cells(i + 1, 2).Value = txt2
Next i
End Sub
Any advice on how to push the data on row 2 downwards .....
I do not know how to give you a hint that would help you adjust your macro so I have coded what I think you are after.
You talk about overwriting data in the 2nd or 3rd row so I assume you have several rows containing data in this format. I have therefore converted your code into a loop that works down column A until it finds a blank row.
I avoid overwriting data below the current row by inserting rows as necessary.
I have changed your code in ways that I believe makes the code more maintainable. I have explained my reasons for
these changes.
I have not explained the new statements I have used. It is generally easy to look up a statement once you know it exists but do ask questions if anything is unclear.
I hope this helps.
Option Explicit
Sub splitcells()
' * With VBA, Integer declares a 16-bit value while Long declares a 32-bit
' value. 16-bit values require special processing and are slower. So
' Long is preferred.
' * I do not like variable names such as i. It does not really matter with
' a tiny macro but with a larger macro it does. It does not matter now
' but it matters when you return to this macro in 6 or 12 months to amend
' it. You want to be able to look at variables and immediately know what
' they are. I have named variables according to my system. I am not
' asking you to like my system but to have a system. I can return to
' macros I wrote years ago and immediately recognise all the variables.
Dim InxSplit As Long
' Dim i As Integer
' * Split returns a string array. A Variant can be hold a string array but
' access is slower. Variants can be very useful but only use then when
' you need the flexibility they offer.
Dim SplitCell() As String
' Dim cell1 As Variant
Dim RowCrnt As Long
' * "Range" operates on the active worksheet. You are relying on the correct
' worksheet being active when the macro is called. Also, when you return
' to the macro in 6 or 12 months will you remember which worksheet is
' supposed to be active. ".Range" operates on the worksheet specified in
' the With statement. It doe not matter which worksheet is active and it
' is absolutely clear which worksheet is the target of this code.
With Worksheets("Sheet1")
RowCrnt = 1 ' The first row containing data.
Do While True
' * I use .Cells(row, column) rather than .Range because it is more
' convenient when you need to change the row and/or column numbers.
' * Note the column value can be a number or a column identifier.
' A = 1, B=2, Z=26, AA = 27, etc. I am not doing arithmetic with
' the columns so I have used "A" and "B" which I find more
' meaningful than 1 and 2.
If .Cells(RowCrnt, "A").Value = "" Then
Exit Do
End If
SplitCell = Split(.Cells(RowCrnt, "A").Value, ",")
If UBound(SplitCell) > 0 Then
' The cell contained a comma so this row is to be spread across
' two or more rows.
' Update the current row
.Cells(RowCrnt, "A").Value = SplitCell(0)
' For each subsequent element of the split value, insert a row
' and place the appropriate values within it.
For InxSplit = 1 To UBound(SplitCell)
RowCrnt = RowCrnt + 1
' Push the rest of the worksheet down
.Rows(RowCrnt).EntireRow.Insert
' Select the appropriate part of the original cell for this row
.Cells(RowCrnt, "A").Value = SplitCell(InxSplit)
' Copy the value from column B from the previous row
.Cells(RowCrnt, "B").Value = .Cells(RowCrnt - 1, "B").Value
Next
End If
RowCrnt = RowCrnt + 1
Loop
End With
End Sub

How to show only columns that have certain values

Okay, I am completely new at this, so sorry for insulting anyone with what I suspect is a simple question. However, I have searched and attempted things for days and can't crack the nut - I just can't seem to get something to do all of the things I want.
Here goes:
I have a worksheet with values that change weekly. The number of rows and columns change as well. However, columns A, B, and C will always have date, name and location data and therefore must be preserved. The values in the columns from D onward include only the numbers 0, 1, 2, or 3.
I need to copy the columns to a second worksheet and then delete all of the columns from D onward that do not have a 2 or a 3 in them. In other words, I need to always keep columns A, B, and C, and also keep any column (and all of its data) if a 2 or 3 shows up anywhere in the column.
Alternately, I bet it would be quicker to cherry pick the first three columns, as well as any other columns that have a 2 or 3 in them, and then paste them to the second worksheet. However, I've read about using Union, which seems like the way to go, but it's way over my head.
Thanks in advance for any solutions.
I do not see the relevance of Union so I hope I have not misunderstood your requirement.
The first task is to determine the last row and column. There are a variety of techniques for finding the last row or column; none of which work in every situation. I believe SpecialCells is the most suitable in this case.
When I am unsure how to achieve some objective, I break it into little tasks, code task 1 and use Debug.Print to output diagnostic information to the Immediate Window. When I have got task 1 working, I add the code for task 2 together with new diagnostic information. So my first macro, Demo1 just outputs the last row and column. Try placing values to the left or below any existing values to see what the macro outputs.
Note: I say little about the statements I am using. In general it is easy to look up a statement once you know it exists. Come back with questions if necessary but please try your own investigation first.
Option Explicit
Sub Demo1()
Dim ColLast As Long
Dim RowLast As Long
' Replace "Source" with the name of your worksheet
With Worksheets("Source")
ColLast = Cells.SpecialCells(xlCellTypeLastCell).Column
RowLast = Cells.SpecialCells(xlCellTypeLastCell).Row
End With
Debug.Print "Last column " & ColLast
Debug.Print "Last row " & RowLast
' Note Cells(RowLast, ColLast) does not have to contain a value.
End Sub
The next task is to identify the columns to delete. I use the worksheet function CountIf to count the number of 2s and 3s in each column starting from column 4 which is column "D".
Sub Demo2()
Dim ColCrnt As Long
Dim ColLast As Long
Dim Rng As Range
Dim RowLast As Long
With Worksheets("Source")
ColLast = Cells.SpecialCells(xlCellTypeLastCell).Column
RowLast = Cells.SpecialCells(xlCellTypeLastCell).Row
For ColCrnt = 4 To ColLast
Set Rng = .Range(.Cells(1, ColCrnt), .Cells(RowLast, ColCrnt))
Debug.Print ColCrnt;
Debug.Print " Num 2s=" & WorksheetFunction.CountIf(Rng, 2);
Debug.Print " Num 3s=" & WorksheetFunction.CountIf(Rng, 3)
Next
End With
End Sub
The final task is to delete the columns without 2s and 3s. For Demo2 I used a For-Loop. The trouble with a For-Loop is you cannot change the End Value within the loop and we will need to do that as we delete columns. So for Demo3, I have to use a Do-Loop.
Sub Demo3()
Dim ColCrnt As Long
Dim ColLast As Long
Dim Rng As Range
Dim RowLast As Long
With Worksheets("Source")
ColLast = Cells.SpecialCells(xlCellTypeLastCell).Column
RowLast = Cells.SpecialCells(xlCellTypeLastCell).Row
ColCrnt = 4
Do While ColCrnt <= ColLast
Set Rng = .Range(.Cells(1, ColCrnt), .Cells(RowLast, ColCrnt))
If WorksheetFunction.CountIf(Rng, 2) + _
WorksheetFunction.CountIf(Rng, 3) > 0 Then
' This column contains a 2 or a 3. Do not delete column.
' Advance to next column
ColCrnt = ColCrnt + 1
Else
' This column does not contain a 2 or 3. Delete column.
.Columns(ColCrnt).EntireColumn.Delete
' Reduce ColLast to allow for deletion.
ColLast = ColLast - 1
End If
Loop
End With
End Sub
Hope the above helps.

Excel VBA Appending data to single Array

Am trying to parse an excel file using Excel VBA.
Here is the sample sata
I did some research and found you can assign ranges to array like
Arrayname = Range("A1:D200")
But am looking for some thing more dynamic, like add the below multiple ranges to a single array.
and my final array will be a single array/table with n is number of rows from all ranges and 4 columns.
Can any one please prvide me a example.
Thank you in adavance.
I think you are asking for more information about moving data between ranges and variables so that is the question I will attempt to answer.
Create a new workbook. Leave Sheet1 empty; set cell B3 of Sheet2 to "abc" and set cells C4 to F6 of Sheet3 to ="R"&ROW()&"C"&COLUMN()
Open the VB Editor, create a module and copy the follow code to it. Run macro Demo01().
Option Explicit
Sub Demo01()
Dim ColURV As Long
Dim InxWkSht As Long
Dim RowURV As Long
Dim UsedRangeValue As Variant
' For each worksheet in the workbook
For InxWkSht = 1 To Worksheets.Count
With Worksheets(InxWkSht)
Debug.Print .Name
If .UsedRange Is Nothing Then
Debug.Print " Empty sheet"
Else
Debug.Print " Row range: " & .UsedRange.Row & " to " & _
.UsedRange.Row + .UsedRange.Rows.Count - 1
Debug.Print " Col range: " & .UsedRange.Column & " to " & _
.UsedRange.Column + .UsedRange.Columns.Count - 1
End If
UsedRangeValue = .UsedRange.Value
If IsEmpty(UsedRangeValue) Then
Debug.Print " Empty sheet"
ElseIf VarType(UsedRangeValue) > vbArray Then
' More than one cell used
Debug.Print " Values:"
For RowURV = 1 To UBound(UsedRangeValue, 1)
Debug.Print " ";
For ColURV = 1 To UBound(UsedRangeValue, 2)
Debug.Print " " & UsedRangeValue(RowURV, ColURV);
Next
Debug.Print
Next
Else
' Must be single cell worksheet
Debug.Print " Value = " & UsedRangeValue
End If
End With
Next
End Sub
The following will appear in the Immediate Window:
Sheet1
Row range: 1 to 1
Col range: 1 to 1
Empty sheet
Sheet2
Row range: 3 to 3
Col range: 2 to 2
Value = abc
Sheet3
Row range: 4 to 6
Col range: 3 to 5
Values:
R4C3 R4C4 R4C5
R5C3 R5C4 R5C5
R6C3 R6C4 R6C5
If you work through the macro and study the output you will get an introduction to loading a range to a variant. The points I particularly want you to note are:
The variable to which the range is loaded is of type Variant. I have never tried loading a single range to a Variant array since the result may not be an array. Even if it works, I would find this confusing.
Sheet1 is empty but the used range tells you than cell A1 is used. However, the variant to which I have loaded the sheet is empty.
The variant only becomes an array if the range contains more than one cell. Note: the array will ALWAYS be two dimensional even if the range is a single row or a single column.
The lower bounds of the array are ALWAYS 1.
The column and row dimensions are not standard with the rows as dimension 1 and the columns as dimension 2.
If there is any doubt about the nature of the range being loaded, you must use IsEmpty and VarType to test its nature.
You may also like to look at: https://stackoverflow.com/a/16607070/973283. Skim the explanations of macros Demo01() and Demo02() which are not relevant to you but set the context. Macro Demo03() shows the advanced technique of loading multiple worksheets to a jagged array.
Now create a new worksheet and leave it with the default name of Sheet4.
Add the follow code to the module. Run macro Demo02().
Sub Demo02()
Dim ColOut As Long
Dim OutputValue() As String
Dim Rng As Range
Dim RowOut As Long
Dim Stg As String
ReDim OutputValue(5 To 10, 3 To 6)
For RowOut = LBound(OutputValue, 1) To UBound(OutputValue, 1)
For ColOut = LBound(OutputValue, 2) To UBound(OutputValue, 2)
OutputValue(RowOut, ColOut) = RowOut + ColOut
Next
Next
With Worksheets("Sheet4")
Set Rng = .Range("A1:D6")
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Set Rng = .Range(.Cells(8, 2), .Cells(12, 4))
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Stg = "C" & 14 & ":G" & 20
Set Rng = .Range(Stg)
End With
Rng.Value = OutputValue
End Sub
Although this macro writes an array to a worksheet, many of the points apply for the opposite direction. The points I particularly want you to note are:
For output, the array does not have to be Variant nor do the lower bounds have to be 1. I have made OutputValue a String array so the values output are strings. Change OutputValue to a Variant array and rerun the macro to see the effect.
I have used three different ways of creating the range to demonstrate some of your choices.
If you specify a range as I have, the worksheet is one of the properties of the range. That is why I can take Rng.Value = OutputValue outside the With ... End With and still have the data written to the correct worksheet.
When copying from a range to a variant, Excel sets the dimensions of the variant as appropriate. When copying from an array to a range, it is your responsibility to get the size of the range correct. With the second range, I lost data. With the third range, I gained N/As.
I hope the above gives you an idea of your options. If I understand your requirement correctly, you will have to:
Load the entire worksheet to Variant
Create a new Array of the appropriate size
Selectively copy data from the Variant to the Array.
Come back withh questions if anything is unclear.

Resources