I'm working on a project for work and I've hit a wall. I'm trying to automate some formatting to speed up a process. On Sheet1, there is a table in the range G2 to W21. The data contained in this table is entered by the user via a userform. After the data is entered, I use this data to drive out Sheet2 is formatted. So far, I've figured out how to handle column G & H of this table the way that I want. I cant figure out how to handle columns I:M and O:W.
Here is the code I've come up with so far:
Dim LineItems As Range, Cell As Range
Dim linearr() As Variant
Dim datasetarr() As Variant
Dim i As Integer
Dim j As Integer
Dim accountnum As Range
Dim accountnumrng As Range
Set LineItems = Sheet1.Range("H2:H21")
Set DataSets = Sheet1.Range("G2:G21")
For Each Cell In LineItems
If Len(Cell.Value) > 0 Then
i = i + 1
ReDim Preserve linearr(1 To i)
linearr(i) = Cell.Value
End If
Next Cell
For Each Cell In DataSets
If Len(Cell.Value) > 0 Then
j = j + 1
ReDim Preserve datasetarr(1 To j)
datasetarr(j) = Cell.Value
End If
Next Cell
Set accountnumrng = Sheet2.Range("B6:B1000").SpecialCells(xlCellTypeConstants, 23)
For Each accountnum In accountnumrng.Cells
accountnum.Offset(1, 1).Cells(1, 1).Resize(UBound(linearr), 1).Value = Application.Transpose(linearr)
accountnum.Offset(1, 0).Cells(1, 1).Resize(UBound(datasetarr), 1).Value = Application.Transpose(datasetarr)
Next accountnum
here is a picture of the table on Sheet1. Outlined in red are the columns I'm trying to work with
I basically just want to expand on what I've figured out so far. Any help would be greatly appreciated.
Below is a Picture of what Sheet2 looks like right now
Below is what I'd like Sheet2 to look like
There is no reason to use an array. Ranges are arrays by their nature.
This should do what you want:
Dim accountnum As Range
Dim accountnumrng As Range
Dim lastrow As Long
Dim sze As Long
lastrow = Sheet1.Range("G2").End(xlDown).Row
sze = lastrow - 2 + 1
Set accountnumrng = Sheet2.Range("B6:B1000").SpecialCells(xlCellTypeConstants, 23)
For Each accountnum In accountnumrng.Cells
accountnum.Offset(1, 8).Resize(sze, 9).Value = Sheet1.Range("O2:W" & lastrow).value
accountnum.Offset(1, 0).Resize(sze, 7).Value = Sheet1.Range("G2:M" & lastrow).value
Next accountnum
Related
I have two data workbooks. One dataset is of refused orders and the other dataset is for current orders. I want to find if i can match orders so that i can utilize the orders that I have in refused file. This way i wont have to make the current order and can simultaneously reduce my stack of orders that have been refused by customers. Here is my Data sheets for refused and current/printed orders.
Current/Printed Orders
Here is datasheet for the refused orders.
Refused Orders
I need to match orders on three things. First the design name needs to match, the product name needs to match and the size needs to match in order to get an "order match".
How can I use excel vba to find matches and create a new excel worksheet in the current order workbook that can show the orders that match between both data sets. The final data output would be order number against order number from both the files.
I am just beginning to learn vba but this is a complex problem that i can not solve. Please help. I wrote a code but it does not run. It says object not defined. Code that i wrote is :
Sub Comparetwosheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1row As Long, ws2row As Long, w1scol As Integer, ws2col As Integer
Dim report As Worksheet
Dim row As Long, col As Integer
Dim R1 As Range
Set R1 = Union(col(5), col(7), col(10))
Set report = Worksheet.Add
'Set numrows = number of rows of data
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' Select cell a1.
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
x = 2
Do While x < NonBlank
x = x + 1
Do While (ws1.R1 = ws2.R1)
If ws1.rw2 = ws2.rw2 Then
report.Cells(1, 1).Value = "Match"
Else: x = x + 1
Loop
Loop
'Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
End Sub
This should be able to do it for you. You are able to set the following variables in the CompareWorksheet subroutine to what you need then to be (dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2). I am using a random dataset from the world bank.
Sub CompareWorksheet()
Dim dataSet1, dataSet2 As Variant
Dim workbook1, workbook2 As String
Dim worksheet1, worksheet2 As String
Dim rowStart1, rowStart2 As Integer
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook1 = "dashboard-data-latest1.xlsx"
worksheet1 = "2. Harmonized Indicators"
dataSet1 = SheetToDataSet(workbook1, worksheet1)
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook2 = "dashboard-data-latest.xlsx"
worksheet2 = "2. Harmonized Indicators"
dataSet2 = SheetToDataSet(workbook2, worksheet2)
'Set this do what columns you are interested in comparing
colPos1 = Array(1, 2, 3)
colPos2 = Array(1, 2, 3)
'Set for where you want to start 1 would be row 1/now Header.
rowStart1 = 2
rowStart2 = 2
'Compares the dataSets
Compare2Sheets dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2
End Sub
Function Compare2Sheets(dataSet1 As Variant, dataSet2 As Variant, colPos1 As Variant, colPos2 As Variant, rowStart1 As Variant, rowStart2 As Variant)
If UBound(colPos1) = UBound(colPos2) Then
For I = rowStart1 To UBound(dataSet1, 1)
For j = rowStart2 To UBound(dataSet2, 1)
matchFlag = 0
For k = 0 To UBound(colPos1)
If dataSet1(I, colPos1(k)) = dataSet2(j, colPos2(k)) Then
matchFlag = matchFlag + 1
End If
Next k
If matchFlag = (UBound(colPos1) + 1) Then
Debug.Print ("Match found in Workbook 1 at row " & I & " and Workbook 2 at row " & j)
End If
Next j
Next I
End If
End Function
Function SheetToDataSet(workbookName As Variant, worksheetName As Variant) As Variant
'SET PAGE CHARACTERISTICS
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'DECLARE VARIABLE
Dim x_matrix As Range
Dim x_copyrange As String
Dim length, lastColumn As Integer
'DEFINE VARIABLE
Workbooks(workbookName).Worksheets(worksheetName).Activate
length = 0
lastColumn = 0
For I = 1 To 10
If length < Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row Then
length = Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row
End If
If lastColumn < Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column Then
lastColumn = Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column + 10
End If
Next I
'Let x_copyrange = .Range(.Cells(1, 1), .Cells(length, lastColumn))
'Return
SheetToDataSet = Workbooks(workbookName).Worksheets(worksheetName).Range(Cells(1, 1), Cells(length, lastColumn))
End Function
I am new to VBA and coding in general and I am being tasked with some coding that is proving difficult. I am trying to copy/transpose/paste values from a two-column PivotTable and I need it to paste vertically on another sheet and break on blanks. (see image) I need to copy each group in the PivotTable then transpose paste values vertically on a new worksheet. I believe I need to count populated rows (using an array?) until I get to a blank row then paste the group. I can picture what I need to do but all my coding attempts are way off. Except for the copy/paste, I have no clue how to code this. I cannot figure out how to capture each group of populated rows to be pasted.
' Copy a vertical range (on "FQNID_Sites" sheet) and paste to a horizontal range in column B (next blank row on "BH_FH" sheet)
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("FQNID_Sites")
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Worksheets("BH_FH")
Dim cellToPasteTo As Range
' Need to loop through each group breaking on each siteNFID in column D (or break on blanks in column E?)
Set rng = Range("$D$2:$E$" & ActiveSheet.UsedRange.Rows.Count)
For Each cell In rng
Set cellToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "B").End(xlUp).Offset(1, 0)
If cell.Value = "" And Not IsNull(copyStart) Then
copyEnd = cell.Offset(-1, 0).Address
ElseIf cell.Value = "" Then
copyStart = cell.Offset(0, -1).Address
End If
If Not IsNull(copyStart) And Not IsNull(copyEnd) Then
sourceSheet.Range(copyStart & ":" & copyEnd).Select
Selection.Copy
cellToPasteTo.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True
End If
Next cell
Application.CutCopyMode = False
I need it to break on each siteNFID/FQNID then paste values for each group vertically in column B on the BH_FH worksheet.
Example of the input and expected output format
This code will work. Tested on similar data structure. I used the code sheet name in the code `Sheet1'. Change as needed.
Option Explicit
Sub runTranspose()
With Sheet1
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
'load range starts to transpose
Dim i As Long
For i = 2 To lastRow
If Len(.Cells(i, 5)) = 0 Then
Dim startTranspose As Range
If startTranspose Is Nothing Then
Set startTranspose = .Cells(i, 5)
Else
Set startTranspose = Union(startTranspose, .Cells(i, 5))
End If
End If
Next
Dim c As Range
For Each c In startTranspose
transposeData c
Next
End With
End Sub
Sub transposeData(r As Range)
With Sheet1
Dim nextRow As Long
nextRow = .Cells(.Rows.Count, 8).End(xlUp).Row + 1
Dim fullRange As Range
Set fullRange = Range(r.Offset(1, -1), r.Offset(1).End(xlDown))
Dim arr As Variant
arr = fullRange.Value
.Cells(nextRow,7).Value = r.offset(-1).Value 'to add label
.Cells(nextRow, 8).Resize(2, UBound(arr)).Value = Application.Transpose(arr)
End With
End Sub
My intention was to have the following code compile data from my "Low CPM 1" worksheet into an array and then filter my active worksheet based on this array. While the macro does seem to affect the filters, none of the values get filtered out. Any help on this matter would be greatly appreciated
Sub Macro1()
Dim CPM1Array(0 To 300) As Variant
For i = 2 To UBound(CPM1Array)
CPM1Array(i) = Sheets("Low CPM 1").Cells(i, 2).Value
Next i
ActiveSheet.Range("$A$1:$H$251").AutoFilter Field:=3, Criteria1:=("<>1 to Ubound(CPM1Array)"), Operator:=xlFilterValues
End Sub
There is no simple way with autofilter to achieve what you want. You cannot use Criteria1:="<>MyArray"
Alternative
We know which values we do not want. We can find out what are the values of the relevant column
Simply store the values of the relevant column in an array and then remove the unnecessary values from it by comparing it with the array which has values we do not want.
Remove blank cells from the array
Pass the final array to the autofilter.
In Action
Let's say our worksheet looks like as shown in the below image. I am taking an example of only 15 rows.
Code
Sub Sample()
Dim ws As Worksheet
Dim MyAr(1 To 5) As String
Dim tmpAr As Variant, ArFinal() As String
Dim LRow As Long
ReDim ArFinal(0 To 0)
Set ws = ActiveSheet
'~~> Creating an array of values which we do not want
For i = 1 To 5
MyAr(i) = i
Next i
With ws
'~~> Last Row of Col C sice you will filter on 3rd column
LRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> Storing the values form C in the array
tmpAr = .Range("C2:C" & LRow).Value
'~~> Compare and remove values which we do not want
For i = 1 To LRow - 1
For j = 1 To UBound(MyAr)
If tmpAr(i, 1) = MyAr(j) Then tmpAr(i, 1) = ""
Next j
Next i
'~~> Remove blank cells from the array by copying them to a new array
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 1) <> "" Then
ArFinal(UBound(ArFinal)) = tmpAr(i, 1)
ReDim Preserve ArFinal(0 To UBound(ArFinal) + 1)
End If
Next i
'~~> Filter on values which you want. Change range as applicable
.Range("$A$1:$H$15").AutoFilter Field:=3, Criteria1:=ArFinal, Operator:=xlFilterValues
End With
End Sub
Output
I am trying to pull strings from column A and move them to column B only if they don't already exist in column B. To do this, I wanted to make a list and scan all of column A with it, however, I'm not sure how to do that in VBA. In python I recall using something along the lines of
[If (x) not in (List)]
but that same approach isnt working for me in Excel.
Currently, I have the following
Sub GatherAll()
GL = List()
rwcnt = WorksheetFunction.CountA(Range("A:A"))
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long
For i = 2 To rwcnt
Cells(i, 1).Value = n
and I want to say something like
if n not in GL, GL.append(n)
continue
End Sub
If anyone could help me out, I would really appreciate it.
Try adapting the following code to your exact needs and see if it helps. If you need help, let us know.
Sub MoveUniqueEntries()
Dim oDict As Object
Dim rToMove As Range
Dim rDest As Range
Dim rLoop As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rToMove = Intersect(Sheet1.Range("A1").CurrentRegion, Sheet1.Columns(1))
Set rDest = Sheet1.Range("B1")
For Each rLoop In rToMove
If oDict.exists(rLoop.Value) Then
'Do nothing
Else
oDict.Add rLoop.Value, 0
rDest.Value = rLoop.Value
Set rDest = rDest.Offset(1)
End If
Next rLoop
End Sub
In your VBA IDE you will have to add a reference. On the tools pulldown menu select references. Then select "Microsoft ActiveX Data Objects 2.8 Library".
Dim rs As New ADODB.Recordset
Dim ws As Excel.Worksheet
Dim lRow As Long
Set ws = Application.ActiveSheet
'Add fields to your recordset for storing data. You can store sums here.
With rs
.Fields.Append "Row", adInteger
.Fields.Append "Value", adInteger
.Open
End With
lRow = 1
'Loop through and record what is in the first column
Do While lRow <= ws.UsedRange.Rows.count
rs.AddNew
rs.Fields("Row").Value = lRow
rs.Fields("Value").Value = ws.Range("A" & lRow).Value
rs.Update
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
'Now go through and list out the unique values in columnB.
lRow = 1
rs.Sort = "value"
Do While lRow <= ws.UsedRange.Rows.count
if rs.Fields("value").Value <> strLast then
ws.Range("B" & lRow).Value = rs.Fields("value").Value
lRow = lRow + 1
End if
strLast = rs.Fields("value").Value
Loop
Cross-platform version (but will be slow for large numbers of values):
Sub UniquesTester()
Dim v, u(), i As Long, n As Long
n = 0
v = Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp)).Value
ReDim u(1 To UBound(v, 1))
For i = 1 To UBound(v, 1)
If IsError(Application.Match(v(i, 1), u, 0)) Then
n = n + 1
u(n) = v(i, 1)
End If
Next i
ReDim Preserve u(1 To n)
Range("c1").Resize(n, 1).Value = Application.Transpose(u)
End Sub
Im coming from a Unix world where I never had to develop something for Office with VBA, I have to do some now and Im having a hard time! Please help me! :)
So I've got 2 Excel Sheets(lets call them Sheet1 and Sheet2) and 2 forms(Form1 and Form2) to edit/add data.
In Sheet1, the first two columns are MovieId and MovieName. We dont know how many rows they will be in this columns.
Form1 controls data in Sheet1, and Form2... in Sheet2.
At Form2 initialization, I want to create a 2 Dimensional Array that will be like (MovieId1,MovieName1;MovieId2,MovieName2;...,...;MovieIdN,MovieNameN), where this data has been extracted from Sheet1, like a sort of Map in Java if you will...
It would actually be ok for me if it was like: (0,"MovieId0;MovieName0";1,"MovieId1,MovieName1";..,"..";N,"MovieIdN,MovieNameN")
I dont know how to create the array with an variable last row number, since the compiler seems to always want a constant to initialize an Array...
Please enlighten me!
Look at the Value method or Value2 property.
e.g. Range("$A$2:$B$4").Value2(1,1)
or
Range("$A$2:$B$4").Value()(1,1)
Array's lower bound start from 1.
lbound(Range("$A$2:$B$4").Value2, 1) - row element starts from
ubound(Range("$A$2:$B$4").Value2, 2) - row element ends
lbound(Range("$A$2:$B$4").Value2, 2) - column element starts from
ubound(Range("$A$2:$B$4").Value2, 2) - column element ends
EDIT: Code to traverse through the array
Dim myAddress As String
Dim dataArray As Variant
Dim rowStart As Long, rowEnd As Long
Dim colStart As Long, colEnd As Long
Dim rowCtr As Long
Dim colCtr As Long
myAddress = "$A$2:$B$4"
dataArray = Range(myAddress).Value2
rowStart = LBound(dataArray, 1)
rowEnd = UBound(dataArray, 1)
colStart = LBound(dataArray, 2)
colEnd = UBound(dataArray, 2)
For rowCtr = rowStart To rowEnd
For colCtr = colStart To colEnd
Debug.Print rowCtr & ":" & colCtr, vbTab & dataArray(rowCtr, colCtr)
Next
Next
EDIT2: In my example, I have assumed the address to be $A$2:$B$4.
You can prefix it with sheet name. e.g. Sheet1!$A$2:$B$4 or Sheet2!$A$2:$B$4
On a side note, array can be defined dynamic (if it is 1 dimensional).
e.g dim my1DArray() as Integer
For double dimension array, see the following code
Dim myArray
Dim dynamicRows As Integer
dynamicRows = 2
ReDim myArray(0 To dynamicRows, 0 To dynamicRows)
myArray(0, 0) = "hello"
dynamicRows = 20
ReDim myArray(0 To dynamicRows, 0 To dynamicRows)
MsgBox myArray(0, 0)
myArray(0, 0) = "hello"
ReDim Preserve myArray(0 To dynamicRows, 0 To dynamicRows)
MsgBox myArray(0, 0)
Rather use the Range object, with this you can also use the UsedRange from the sheet
Sub Macro1()
Dim sheet As Worksheet
Dim range As range
Dim row As Integer
Set sheet = Worksheets("Sheet1")
Set range = sheet.UsedRange
For row = 1 To range.Rows.Count
Next row
End Sub
assuming the data starts in A1
Dim vArr as variant
vArr=worksheets("Sheet1").range("A1").resize(worksheets("Sheet1").range("A65535").end(xlup).row,2)
Do you mean:
Dim thearray() As Variant
ReDim thearray(1, range.Rows.Count)
You can also use a recordset and GetRows to return an array from a worksheet.
Slight mod to Charles' answer:
Dim vArr as variant
vArr = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
Assuming of course that there isn't any stray data in Sheet1.