I am trying to get data from an Excel sheet. If the date indicated on the column header is today's date then contents of that column need to be copied. After checking all the columns, the final data needs to be pasted in another sheet.
I have built a macro to get stock prices from web. Now I need to filter the data based on date to make it ready for making graphs. I have tried multiple variations of the below code but till now no success. Copying the ranges is the problem area.
Sub graphs()
Dim d As Date
Dim a As Variant
Dim f As Variant
Dim b As Variant
Dim x As Variant
Dim col As Variant
Dim r As Range
Dim j As Range
r = ThisWorkbook.Sheets("historic price").Range(Cells(1, 1), Cells(50, 1)) ' this is to copy the first column with company names
b = WorksheetFunction.CountA(Rows(1))
For x = 2 To b
a = ThisWorkbook.Sheets("historic price").Cells(1, x) ' below 3 lines are to extract date from column header
f = WorksheetFunction.Search(" ", a, 10)
d = Mid(a, 10, (f - 10))
If d = Date Then
r = Union(r, Range(Cells(1, x), Cells(50, x))) ' this is to add data to r
End If
Next x
col = r.Columns.Count ' count number of columns stored in r
r.Copy
Worksheets("graphs").Activate
Set j = ThisWorkbook.Sheets("Graphs").Range(Cells(1, 1), Cells(50, col))
j.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
ThisWorkbook.Sheets("Graphs").Cells(1, 1).Select
End Sub
You need to set the new range
For example
Set rng1 = .Range("A1")
Set rng2 = .Range("A2")
Set NewRng = .Range(rng1.Address & ":" & rng2.Address)
or
Set newRng = Union(rng1, rng2)
So you need to set r
set r = Union(r, Range(Cells(1, x), Cells(50, x)))
Related
Hope you you can help me here. I have a repetitive task every week, which I could do the same way every single time through Excel formulas, but I am looking for a more automated way of going about this.
What I want to achieve is to set-up a dynamic range that will look for multiple key words such as in this case "OA" & "SNC" and if it matches it will return the value in the column G & H respectively. At the same time it has to skip blank rows. What is the best way to go about this?
I figured it shouldn't be too hard, but I cannot figure it out.
As per image above, I want to consolidate the charges per category (OA & SNC) in the designated columns ("G" & "H") on row level.
My approach to the task
Procedure finds data range, loops through it's values, adding unique values to the dictionary with sum for specific row and then loads all these values along with sums per row.
Option Explicit
Sub CountStuff()
Dim wb As Workbook, ws As Worksheet
Dim lColumn As Long, lRow As Long, lColTotal As Long
Dim i As Long, j As Long
Dim rngData As Range, iCell As Range
Dim dictVal As Object
Dim vArr(), vArrSub(), vArrEmpt()
'Your workbook
Set wb = ThisWorkbook
'Set wb = Workbooks("Workbook1")
'Your worksheet
Set ws = ActiveSheet
'Set ws = wb.Worksheets("Sheet1")
'Number of the first data range column
lColumn = ws.Rows(1).Find("1", , xlValues, xlWhole).Column
'Number of the last row of data range
lRow = ws.Cells(ws.Rows.Count, lColumn).End(xlUp).Row
'Total number of data range columns
lColTotal = ws.Cells(1, lColumn).End(xlToRight).Column - lColumn + 1
'Data range itself
Set rngData = ws.Cells(1, lColumn).Resize(lRow, lColTotal)
'Creating a dictionary
Set dictVal = CreateObject("Scripting.Dictionary")
'Data values -> array
vArr = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, _
rngData.Columns.Count).Value
'Empty array
ReDim vArrEmpt(1 To UBound(vArr, 1))
'Loop through all values
For i = LBound(vArr, 1) To UBound(vArr, 1)
For j = LBound(vArr, 2) To UBound(vArr, 2)
'Value is not numeric and is not in dictionary
If Not IsNumeric(vArr(i, j)) And _
Not dictVal.Exists(vArr(i, j)) Then
'Add value to dictionary
dictVal.Add vArr(i, j), vArrEmpt
vArrSub = dictVal(vArr(i, j))
vArrSub(i) = vArr(i, j - 1)
dictVal(vArr(i, j)) = vArrSub
'Value is not numeric but already exists
ElseIf dictVal.Exists(vArr(i, j)) Then
vArrSub = dictVal(vArr(i, j))
vArrSub(i) = vArrSub(i) + vArr(i, j - 1)
dictVal(vArr(i, j)) = vArrSub
End If
Next j
Next i
'Define new range for results
Set rngData = ws.Cells(1, lColumn + lColTotal - 1). _
Offset(0, 2).Resize(1, dictVal.Count)
'Load results
rngData.Value = dictVal.Keys
For Each iCell In rngData.Cells
iCell.Offset(1, 0).Resize(lRow - 1).Value _
= Application.Transpose(dictVal(iCell.Value))
Next
End Sub
I've used a simple custom function, possibly overkill as this could be done with worksheet formulae, but given that your ranges can vary in either direction...
Function altsum(r As Range, v As Variant) As Variant
Dim c As Long
For c = 2 To r.Columns.Count Step 2
If r.Cells(c) = v Then altsum = altsum + r.Cells(c - 1)
Next c
If altsum = 0 Then altsum = vbNullString
End Function
Example below, copy and formula in F2 across and down (or apply it one go with another bit of code).
Attached is my code so far. My issue is that I can't seem to get the macro to compare only whole words sheet(2) column B activecell (which contains more than one word within the cell) to the range (column A) in sheet(1) - which is a list of whole words (pictured below). Everything else in the code works fine but at present it only works for exact matches?
I have tried using the wildcard approach but it seems to match any characters whereas I need it to compare whole words from the sentences (which are varying each time in the active cell).
Any tips on what I can add so that the countif function finds whole words instead of characters etc? The same problem is for the Find function, where it will only find the exact match and return errors if it doesn't find exactly that.
Sub FMEATest1()
Dim count As Integer
Dim count2 As Integer
Dim n As Integer
Dim m As Integer
Dim FML As Range
Dim i As Range
'Dim m As Integer
Dim a As Range
Dim b As Integer
Dim FML2 As Range
Dim WrdArray() As String
Dim k As Range
Dim j As Range
Dim Splitsentence As Range
Worksheets(1).Activate
Range(("A1"), Range("A1").End(xlDown)).Select
Set FML = Selection
Worksheets(2).Activate
Range("B3").Activate
Do Until ActiveCell.value = ""
Set i = ActiveCell
WrdArray() = Split(i, , , vbTextCompare)
Set Splitsentence = WrdArray().value
count = Application.WorksheetFunction.CountIf(FML, Splitsentence)
'm = (ActiveCell.Row) + count - 1
n = Selection.Rows.count
Do Until n = (count)
ActiveCell.Offset(1, 0).EntireRow.Insert
Set a = Selection.Offset(1, 0)
ActiveCell.COPY
ActiveCell.Offset(1, 0).value = ActiveCell.value
ActiveCell.PasteSpecial
Range(i, a).Select
n = Selection.Rows.count
Loop
'Copying Failure Modes for each Keyword
Lookfor = ActiveCell.value & "*"
Worksheets(1).Activate
Cells.Find(What:=Lookfor, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False).Select
Set FML2 = Selection
Set j = ActiveCell
count2 = Application.WorksheetFunction.CountIf(FML2, j)
m = Selection.Rows.count
Do Until m = (count)
Set k = Selection.Offset(1, 0)
Range(j, k).Select
m = Selection.Rows.count
Loop
Selection.Offset(0, 1).COPY
Worksheets(2).Activate
ActiveCell.Offset(0, 1).PasteSpecial
ActiveCell.Offset(n, -1).Activate
Loop
End Sub
The difficulty is that the activecell contains a sentence and this sentence varies each time as in the example below, but I need the macro to match whole key words from column B in sheet(2) to Column A in sheet (1).
Can someone please make my images publically visible please?
So I would be looking for the code to be able to find the word "charge" from cell B3 out of the whole sentence (and get it to find it in column A of sheet(1)). And the word "Hold" from B4 from the whole sentence. These can change so much so I can't manually input them into the find function I need to reference the activecell.
The final solution of the code should give the following result (I've given two examples for "charge" and "hold"):
I have assumed data as outlined in the comments so you may have to amend sheet names and ranges. Also depending on what other data you have in your sheet it may need some adjustment for the output, but if you mock up an example based on your screenshots it should work as desired.
Sub x()
Dim v, vOut(), i As Long, j As Long, k As Long, va, r As Range, r1 As Long
'Assumes list of words in A1/B1 and down on "Sheet1"
Set r =Sheets("Sheet1").Range("A1").CurrentRegion
With Sheets("Sheet2") 'Assumes phrases in B1 and down on "Sheet2"
v = .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Value
.Columns(2).ClearContents
End With
ReDim vOut(1 To UBound(v) * r.Rows.Count, 1 To 2)
For i = LBound(v, 1) To UBound(v, 1)
va = Split(v(i, 1))
For j = LBound(va) To UBound(va)
For r1 = 1 To r.Rows.Count
If LCase(Application.Trim(va(j))) = LCase(r.Cells(r1, 1)) Then
k = k + 1
vOut(k, 1) = v(i, 1)
vOut(k, 2) = r.Cells(r1, 2)
End If
Next r1
Next j
Next i
Sheets("Sheet2").Range("B1").Resize(k, 2) = vOut 'Puts results in B1/C1 and down on "Sheet2"
End Sub
I am working on a macro to copy a varied number of cells to a row, transpose and paste into a different sheet, in the next empty cell in a column. Then the idea is to match each transposed item with the ID from the row it originated from. The number of rows in the ID column will vary as well.
Looking at the example below, ID 1 is associated with Co D and Co R. Transposing would create the need for ID 1 to be copied into the two cells adjacent to the destination. This example I created has them on the same sheet, but for the code itself it will be on a different sheet.
The problem appears in copying the range to be transposed. I can't seem to figure out how to grab the whole row. The macro correctly pastes the value in the next available cell in the destination, but the version of the code I have now only copies the last result in the row, and not the whole row which is my intent. I haven't even gotten to the part of matching the ID to the Co in the Destination column, but I am dreading it already. The code I have is as follows;
Sub Testing()
Dim TearS As Worksheet: Set TearS = Worksheets(1)
Dim FeeS As Worksheet: Set FeeS = Worksheets(2)
Dim EntryS As Worksheet: Set EntryS = Worksheets(3)
Dim Stage2 As Worksheet: Set Stage2 = Worksheets(4)
Dim Stage3 As Worksheet: Set Stage3 = Worksheets(5)
Dim Bbg As Range: Set Bbg = EntryS.Range("F4:T199")
Dim TDest As Range: Set TDest = Stage2.Range("F5:T200")
Dim DateA As Range: Set DateA = Stage2.Range("G5:G200")
Dim DateB As Range: Set DateB = TearS.Range("E5:E200")
Dim DesA As Range: Set DesA = Stage2.Range("J5:J200")
Dim DesB As Range: Set DesB = TearS.Range("O5:O200")
Dim DesC As Range: Set DesC = Stage3.Range("C5:C200")
Dim CpnMatA As Range: Set CpnMatA = Stage2.Range("Y5:Y200")
Dim CpnMatB As Range: Set CpnMatB = TearS.Range("P5:P500")
Dim SettA As Range: Set SettA = Stage2.Range("I5:I200")
Dim SettB As Range: Set SettB = TearS.Range("Q5:Q200")
Dim MinA As Range: Set MinA = Stage2.Range("AA5:AA200")
Dim MinB As Range: Set MinB = Stage3.Range("D5:D200")
Dim MWOB As Range: Set MWOB = TearS.Range("N5:N200")
Dim Cel As Range
For Each Cel In DesC
If IsEmpty(Cel) = False Then
Cel.Offset(0, 1).End(xlToRight).Copy
TearS.Range("N3").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End If
Next Cel
End Sub
Edit: Jeeped's solution that you can see in the answer below works swimmingly. Make sure that there are no errors in the source data, or you may get a run-time error 13.
Try transposing within a 2-D array before passing the values back to the worksheet.
Sub rewrite()
Dim lr As Long, a As Long, b As Long, val As Variant, vals As Variant
With Worksheets("sheet6")
.Range("F:G").Clear
lr = Application.Max(.Cells(.Rows.Count, "B").End(xlUp).Row, _
.Cells(.Rows.Count, "C").End(xlUp).Row, _
.Cells(.Rows.Count, "D").End(xlUp).Row, _
.Cells(.Rows.Count, "E").End(xlUp).Row)
vals = .Range(.Cells(2, "A"), .Cells(lr, "E")).Value2
For a = LBound(vals, 1) To UBound(vals, 1)
ReDim val(1 To UBound(vals, 2), 1 To 2)
For b = LBound(val, 1) To UBound(val, 1) - 1
If CBool(Len(vals(a, b + 1))) Then
val(b, 1) = vals(a, 1)
val(b, 2) = vals(a, b + 1)
End If
Next b
.Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Resize(UBound(val, 1), UBound(val, 2)) = val
Next a
End With
End Sub
My question is: how to transpose the last four rows of the column G into different columns?
I usually use this static code:
Worksheets("Sheet8").Range("A1:A5").Copy
Worksheets("Sheet9").Range("A1").PasteSpecial Transpose:=True
But it doesn't allow me to stay on the same Sheet.
So I am trying to combine it with this code:
Dim r As Range, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Set r = Cells(N, 1).EntireRow
r.Copy
Cells(N + 1, 1).PasteSpecial Transpose:=True
r.Delete
Before
After
Any help is appreciated
Untested:
Dim c As Range, v
'find last-used cell in ColG
Set c = Cells(Rows.Count, "G").End(xlUp)
With c.offset(-3,0) 'starting with the cell 3 rows above the last-used cell...
v = .resize(4,1).value 'get the value of the 4-row/1-col range below
.resize(4,1).clearcontents '...then clear that range
.resize(1,4).value = Application.Transpose(v) 'place the values in a row
End with
Hi I am trying to copy multiple columns from one workbook to another, and below is the code how I copied one and need help in making the code more optimized as I don't want to write same code for all the columns. below is the code.
Sub Copymc()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("H:\testing\demo\test2.xlsx")
Set y = Workbooks.Open("H:\testing\demo\test1.xlsx")
Dim LastRow As Long
Dim NextRow As Long
' determine where the data ends on Column B Sheet1
x.Worksheets("Sheet1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Select
LastRow = ActiveCell.Row
' copy the data from Column B in Sheet 1
Range("A2:A" & LastRow).Copy
' Determine where to add the new data in Column C Sheet 2
y.Worksheets("Sheet1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Offset(1, 0).Select
NextRow = ActiveCell.Row
' paste the data to Column C Sheet 2
y.Worksheets("Sheet1").Range("A" & NextRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
End Sub
I tried to put all columns in range statement but problem I found was how to paste? How can I do it for multiple columns without repeating the code? Thanks in advance.
Let's say you want to copy columns A-D:
Sub Copymc()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("H:\testing\demo\test2.xlsx")
Set y = Workbooks.Open("H:\testing\demo\test1.xlsx")
Dim LastRow As Long
Dim NextRow As Long
' determine where the data ends on Column B Sheet1
x.Worksheets("Sheet1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Select
LastRow = ActiveCell.Row
' copy the data from Column B in Sheet 1
Range("A2:D" & LastRow).Copy y.worksheets("Sheet1").range("a65536").end(xlup).offset(1,0)
' Determine where to add the new data in Column C Sheet 2
'y.Worksheets("Sheet1").Activate
'Range("A65536").Select
'ActiveCell.End(xlUp).Offset(1, 0).Select
'NextRow = ActiveCell.Row
' paste the data to Column C Sheet 2
'y.Worksheets("Sheet1").Range("A" & NextRow).Select
'ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
End Sub
I try to avoid the copy and paste functions as much as possible. To get around this I would loop through all of the values in the column and move them to your other workbook as such:
Sub test()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("H:\testing\demo\test2.xlsx")
Set y = Workbooks.Open("H:\testing\demo\test1.xlsx")
Dim LastRow As Long
LastRow = x.Sheets("Sheet1").Range("A65536").End(xlUp).Row
For i = 1 To LastRow
CopyVal = x.Sheets("Sheet1").Range("A1").Offset(i, 0).Value
CopyVal2 = x.Sheets("Sheet1").Range("A1").Offset(i, 1).Value
CopyVal3 = x.Sheets("Sheet1").Range("A1").Offset(i, 2).Value
CopyVal4 = x.Sheets("Sheet1").Range("A1").Offset(i, 3).Value
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 3).Value = CopyVal4
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 2).Value = CopyVal3
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 1).Value = CopyVal2
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 0).Value = CopyVal
Next
End Sub