I have a very basic knowledge and VBA but due to coding in other programming languages, I have a thought if I can copy-paste the data using specific column names in vba-excel. I use the following code till now but want to get over as I get stuck too often.
ThisWorkbook.Worksheets("Sheets2").Activate
lastrow = Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("B2:B" & lastrow).Copy Worksheets("Sheet1").Range("a65536").End(xlUp).Offset(1, 2)
Range("A2:A" & lastrow).Copy Worksheets("Sheet1").Range("a65536").End(xlUp).Offset(1, 1)
Application.CutCopyMode = False
This will copy A and B column from Sheet2 to B and C column in Sheet1. Now can I do something like
Sheet2.colname.copy Sheet1.colname.offset
I am just curious and any help is appreciated. Thanks.
I often declare Const for the columns I'm referring to throughout complex code so I can refer to them by 'name'.
Const ItemNumCol = 1
Const DescCol = 2
Const CostCol = 3
etc...
It's not automatic, but by declaring them globally, it minimizes the pain of rearranging columns, and prevents me from having to go back to my spreadsheet to count every 2 minutes.
Usage Example
Dim ws1 as Worksheet
Dim ws2 as Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheets1")
Set ws2 = ThisWorkbook.Worksheets("Sheets2")
LastRow = ws2.UsedRange.Rows.Count + 1
ws.range(cells(2,DescCol),cells(LastRow,DescCol).copy ws1.range(ws1.UsedRange.Rows.Count + 1, DescCol)
You may have to flip the "Row, Col" references within Cells(), I can never remember which way they go, but IntelliSense in the VBE IDE will tell you.
In facts if you want just to use names, you can't do it in general, maybe in tables (select your column and add an array) but not sure...
to use something like this :
Sheet2.colname.copy Sheet1.colname.offset
you can use :
Sheet2.columns(index).copy Sheet1.columns(index).offset
Index is a number starting at 1, and you can find it with a simple For structure and then inject your result in your copies instructions! ;)
Here is a way to do it :
Sub MasterCopy()
Copy_Columns 0, 0
End Sub
Here is a routine that will help you use the function below (and you can reuse parameters if you want to unite them in only one routine)
Sub Copy_Columns(ByVal HorizontalOffset As Integer, ByVal VerticalOffset As Integer)
Dim ColCopy As Integer
Dim ColPaste As Integer
ColCopy = GetColName("SheetCopy", "ColToCopy")
ColPaste = GetColName("SheetPaste", "ColToPaste")
Sheets("SheetCopy").Columns(ColCopy).Copy Sheets("SheetPaste").Columns(ColPaste).Offset(VerticalOffset, HorizontalOffset)
End Sub
And so you can use that function everywhere to find your columns by name in a specific sheet
Public Function GetColName(ByVal SheetName As String, ByVal ColName As String)
For j = 1 To Sheets(SheetName).Cells(1, 1).End(xlToRight).Column
If LCase(Sheets(SheetName).Cells(1, j)) <> LCase(Column_Name) Then
Else
GetColName = j
Exit For
End If
Next j
If IsEmpty(GetColName) Then GetColName = 0
End Function
Enjoy! ;)
Related
I have a large data set which I need to manipulate and create individual worksheets. Within column B all cells which are coloured Green I would like to make a new worksheet for. Please see screen shot.
For example I would like to create worksheets titled "Shopping" & "Retail". Once the worksheet is created, I would then like to copy all the data between the "worksheet title" (Green Cells) from columns ("B:C") & ("AI:BH") Please see screen shot below for expected output;
The code I have so far is below as you can see it is not complete as I do not know how I would go about extracting data between the "Green Cells".
Sub wrksheetadd()
Dim r As Range
Dim i As Long
Dim LR As Long
Worksheets("RING Phased").Select
LR = Range("B65536").End(xlUp).Row
Set r = Range("B12:B" & (LR))
For i = r.Rows.Count To 1 Step -1
With r.Cells(i, 1)
If .DisplayFormat.Interior.ColorIndex = 35 Then
MsgBox i
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cells (i,1).Value
Worksheets("RING Phased").Select
End If
End With
Next i
End Sub
Any help around this would be much appreciated.
Sorry for taking a while to get back to this, I've been somewhat busy the last few days, so I haven't had much time to be on StackOverflow.
Anyway, the way I'd go about this would be to store all the found values in an array, and then loop through that array in order to find the distance between them.
The following code works for me, using some very simplified data, but I think the principle is sound:
Option Explicit
Option Base 0
Sub wrksheetadd()
Dim r As Range, c As Range
Dim i As Long: i = 0
Dim cells_with_color() As Range: ReDim cells_with_color(1)
With Worksheets("RING Phased")
' Since it doesn't seem like the first cell you want to copy from is colored, hardcode that location here.
' This also saves us from having to test if the array is empty later.
Set cells_with_color(i) = .Range("B12")
i = i + 1
Set r = Range(.Range("B13"), .Range("B" & .Cells.Rows.Count).End(xlUp))
' Put all the cells with color in the defined range into the array
For Each c In r
If c.DisplayFormat.Interior.ColorIndex = 35 Then
If i > UBound(cells_with_color) Then
ReDim Preserve cells_with_color(UBound(cells_with_color) + 1)
End If
Set cells_with_color(i) = c
i = i + 1
End If
Next
' Loop through the array, and copy from the previous range value to the current one into a new worksheet
' Reset counter first, we start at 1, since the first range-value (0 in the array) is just the start of where we started checking from
' (Hmm, reusing variables may be bad practice >_>)
i = 1
While i <= UBound(cells_with_color)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cells_with_color(i).Value
' Set the range to copy - we could just do this in the copy-statement, but hopefully this makes it slightly easier to read
Set r = .Rows(CStr(cells_with_color(i - 1).Row) + 1 & ":" & CStr(cells_with_color(i).Row))
' Change the destination to whereever you want it on the new sheet. I think it has to be in column one, though, since we copy entire rows.
' If you want to refine it a bit, just change whatever you set r to in the previous statement.
r.Copy Destination:=Worksheets(CStr(cells_with_color(i).Value)).Range("A1")
i = i + 1
Wend
End With
End Sub
It probably lacks some error-checking which ought to be in there, but I'll leave that as an exercise to you to figure out. I believe it is functional. Good luck!
I'm attempting to take the text in each cell of column A and assign a value to each cell in column B depending on the text in column A. For example, I have a list of versions that are identified by four-letter abbreviations of cities, and all of those versions are regionally assigned to different factories to be produced. So let's say I have an "AUST", "DAFW", "HOUS", and more versions all assigned to the location of "ARLINGTON". How would I most concisely use VBA to automate that once I have all the versions plugged in? Something like
If A2="AUST" Then
B2="ARLINGTON"
ElseIf A2="DAFW" Then
B2="ARLINGTON"
I suppose something like this would work, however I can't believe that there's not a faster and more concise way. Does this make any sense? I've been pulling my hair out for about a week now trying to figure this out... Thanks for any help!
This is a little simpler using OR:
If A2="AUST" OR A2="DAFW" Then
B2="ARLINGTON"
ElseIf A2 = "ABCD" OR A2 = "WZYZ" Then
B2="SOMETHING"
'ETC...
However, if you are iterating over column A, the variable "A2" is strange. But I am not sure how you are doing this. Maybe supply more code and we can help you more.
This could be done with excel formulas as well, though I always prefer to use VBA. This should work the way you want :
Sub yourFunk()
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
arlington = Array("AUST", "DAFW", "HOUS")
otherLocation = Array("XXXX", "YYYY", "ZZZZ")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For x = 2 To lastRow
If stringIsInArray(ws.Cells(x, 1), arlington) Then
ws.Cells(x, 2) = "ARLINGTON"
ElseIf stringIsInArray(ws.Cells(x, 1), otherLocation) Then
ws.Cells(x, 2) = "OTHER LOCATION"
End If
Next x
End Sub
Function stringIsInArray(stringToBeFound As String, arr As Variant) As Boolean
stringIsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
If you need me to explain the code, please do let me know :)
The fastest way is to use Dictionary.
Let's say, your data is present in the following range:
A2 = "AUST"
A3 = "DAFW"
Now, check this code:
'Needs reference to Microsoft Scripting Runtime
Sub Translate()
Dim dic As Dictionary
Dim i As Integer, sTmp As String
Set dic = New Dictionary
dic.Add "AUST", "ARLINGTON"
dic.Add "DAFW", "ARLINGTON"
For i = 2 To 3
sTmp = ThisWorkbook.Worksheets(1).Range("A" & i)
Debug.Print sTmp, "-", dic(sTmp)
Next
Set dic = Nothing
End Sub
Note: This code is just an example!
For further information please see: https://msdn.microsoft.com/en-us/library/office/gg251825.aspx
I have a database that has in excess on 200,000 rows. When I was writing a VBA script I had a database of about 20,000 rows in mind so I didn't care whether the database was filtered or not because the VBA script ran quickly. So given the realization that the database is huge and testing the VBA script I was surprised to notice how slowly it ran. So without further to say this is how my code looks like :
Set wsDB = ThisWorkbook.Sheets("DB")
Dim nameIndex As Long: nameIndex = Application.Match(name, wsDB.Rows(1), 0)
Dim formula As String
formula = "=IFERROR(AVERAGEIFS(" + GRA(nameIndex) + "," + GRA(dateIndex) + ",R2C," + GRA(cellNameIndex) + ",RC1" + "),"""")"
where GRA is a function that returns the address of the range of a column.
Private Function GRA(ByRef rngIndex As Long)
GRA = "DB!" + CStr(Range(Cells(2, rngIndex), Cells(rowNos, rngIndex)).Address(1, 1, xlR1C1, 0, 0))
End Function
So given that I now filter the table beforehand how can I adjust my code so that it ignores all the hidden rows and takes into account only what is visible. Of course I am aware that a simple dirty solution would be to simply copy the filter database and paste it in a new sheet but that will affect the performance which is what I'm trying to improve.
You can use the following function to return a range of only visible cells.
Function VisibleCells(Rng As Range) As Variant
Dim R As Range
Dim Arr() As Integer
Dim RNdx As Long
Dim CNdx As Long
If Rng.Areas.Count > 1 Then
VisibleCells = CVErr(xlErrRef)
Exit Function
End If
ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
For RNdx = 1 To Rng.Rows.Count
For CNdx = 1 To Rng.Columns.Count
Set R = Rng(RNdx, CNdx)
If (R.EntireRow.Hidden = True) Or _
(R.EntireColumn.Hidden = True) Then
Arr(RNdx, CNdx) = 0
Else
Arr(RNdx, CNdx) = 1
End If
Next CNdx
Next RNdx
VisibleCells = Arr
End Function
The above code came from http://www.cpearson.com/excel/VisibleCells.aspx.
Normally I would only post code that I write however this does exactly what I was thinking.
I'm for a solution to part of a macro I'm writing that will hide certain (fixed position) rows across a few different sheets. I currently have:
Sheets(Sheet1).Range("5:20").EntireRow.Hidden = True
To hide rows 5-20 in Sheet1. I also would like to hide (for arguements sake), row 6, row 21, and rows 35-38 in Sheet2 - I could do this by repeating the above line of code 3 more times; but am sure there's a better way of doing this, just as a learning exercise.
Any help much appreciated :)
Chris
Specify a Union of some ranges as follows
With Sheet1
Union(.Range("1:5"), .Rows(7), .Range("A10"), .Cells(12, 1)).EntireRow.Hidden = True
End With
Here is a try:
Sub hideMultiple()
Dim r As Range
Set r = Union(Range("A1"), Range("A3"))
r.EntireRow.Hidden = True
End Sub
But you cannot Union range from several worksheets, so you would have to loop over each worksheet argument.
This is a crude solution: no validation, no unhiding of existing hidden rows, no check that I have a sheet name as first parameter, etc. But it demonstrates a technique that I often find useful.
I load an array with a string of parameters relevant to my current problem and code a simple loop to implement them. Look up the sub and function declarations and read the section on ParamArrays for a variation on this approach.
Option Explicit
Sub HideColumns()
Dim InxPL As Integer
Dim ParamCrnt As String
Dim ParamList() As Variant
Dim SheetNameCrnt As String
ParamList = Array("Sheet1", 1, "5:6", "Sheet2", 9, "27:35")
SheetNameCrnt = ""
For InxPL = LBound(ParamList) To UBound(ParamList)
ParamCrnt = ParamList(InxPL)
If InStr(ParamCrnt, ":") <> 0 Then
' Row range
Sheets(SheetNameCrnt).Range(ParamCrnt).EntireRow.Hidden = True
ElseIf IsNumeric(ParamCrnt) Then
' Single Row
Sheets(SheetNameCrnt).Range(ParamCrnt & ":" & _
ParamCrnt).EntireRow.Hidden = True
Else
' Assume Sheet name
SheetNameCrnt = ParamCrnt
End If
Next
End Sub
I have the following Data in Excel.
CHM0123456 SRM0123:01
CHM0123456 SRM0123:02
CHM0123456 SRM0256:12
CHM0123456 SRM0123:03
CHM0123457 SRM0789:01
CHM0123457 SRM0789:02
CHM0123457 SRM0789:03
CHM0123457 SRM0789:04
What I need to do is pull out all the relevent SRM numbers that relate to a single CHM ref. now I have a formular that will do some thing like this
=INDEX($C$2:$C$6, SMALL(IF($B$8=$B$2:$B$6, ROW($B$2:$B$6)-MIN(ROW($B$2:$B$6))+1, ""), ROW(A1)))
however this is a bit untidy and I really want to produce this same using short vb script, do i jsut have to right a loop that will run though and check each row in turn.
For x = 1 to 6555
if Ax = Chm123456
string = string + Bx
else
next
which should give me a final string of
SRM0123:01,SRM123:02,SRM0256:12,SRM0123:03
to use with how i want.
Or is ther a neater way to do this ?
Cheers
Aaron
my current code
For x = 2 To 6555
If Cells(x, 1).Value = "CHM0123456" Then
outstring = outstring + vbCr + Cells(x, 2).Value
End If
Next
MsgBox (outstring)
End Function
I'm not sure what your definition of 'neat' is, but here is a VBA function that I consider very neat and also flexible and it's lightning fast (10k+ entires with no lag). You pass it the CHM you want to look for, then the range to look in. You can pass a third optional paramater to set how each entry is seperated. So in your case you could write (assuming your list is :
=ListUnique(B2, B2:B6555)
You can also use Char(10) as the third parameter to seperat by line breaks, etc.
Function ListUnique(ByVal search_text As String, _
ByVal cell_range As range, _
Optional seperator As String = ", ") As String
Application.ScreenUpdating = False
Dim result As String
Dim i as Long
Dim cell As range
Dim keys As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
On Error Resume Next
For Each cell In cell_range
If cell.Value = search_text Then
dict.Add cell.Offset(, 1).Value, 1
End If
Next
keys = dict.keys
For i = 0 To UBound(keys)
result = result & (seperator & keys(i))
Next
If Len(result) <> 0 Then
result = Right$(result, (Len(result) - Len(seperator)))
End If
ListUnique = result
Application.ScreenUpdating = True
End Function
How it works: It simple loops through your range looking for the search_string you give it. If it finds it, it adds it to a dictionary object (which will eliminate all dupes). You dump the results in an array then create a string out of them. Technically you can just pass it "B:B" as the search array if you aren't sure where the end of the column is and this function will still work just fine (1/5th of a second for scanning every cell in column B with 1000 unique hits returned).
Another solution would be to do an advancedfilter for Chm123456 and then you could copy those to another range. If you get them in a string array you can use the built-in excel function Join(saString, ",") (only works with string arrays).
Not actual code for you but it points you in a possible direction that can be helpful.
OK, this might be pretty fast for a ton of data. Grabbing the data for each cell takes a ton of time, it is better to grab it all at once. The the unique to paste and then grab the data using
vData=rUnique
where vData is a variant and rUnique is the is the copied cells. This might actually be faster than grabbing each data point point by point (excel internally can copy and paste extremely fast). Another option would be to grab the unique data without having the copy and past happen, here's how:
dim i as long
dim runique as range, reach as range
dim sData as string
dim vdata as variant
set runique=advancedfilter(...) 'Filter in place
set runique=runique.specialcells(xlCellTypeVisible)
for each reach in runique.areas
vdata=reach
for i=lbound(vdata) to ubound(vdata)
sdata=sdata & vdata(i,1)
next l
next reach
Personally, I would prefer the internal copy paste then you could go through each sheet and then grab the data at the very end (this would be pretty fast, faster than looping through each cell). So going through each sheet.
dim wks as worksheet
for each wks in Activeworkbook.Worksheets
if wks.name <> "CopiedToWorksheet" then
advancedfilter(...) 'Copy to bottom of list, so you'll need code for that
end if
next wks
vdata=activeworkbook.sheets("CopiedToWorksheet").usedrange
sData=vdata(1,1)
for i=lbound(vdata) + 1 to ubound(vdata)
sData=sData & ","
next i
The above code should be blazing fast. I don't think you can use Join on a variant, but you could always attempt it, that would make it even faster. You could also try application.worksheetfunctions.contat (or whatever the contatenate function is) to combine the results and then just grab the final result.
On Error Resume Next
wks.ShowAllData
On Error GoTo 0
wks.UsedRange.Rows.Hidden = False
wks.UsedRange.Columns.Hidden = False
rFilterLocation.ClearContents