New to VBA and am trying to essentially lookup column headers in on sheet to another and if match copy data over...
I was told that I can store my headers in a string array then loop through and compare the headers to my array to see if they match.
ie: For each c In
Sheet1.Range("A1:BA1").offset(rownumber -1)
But I'm not sure what that means? How do I store my headers in a string array? Sorry if this is a super basic question. I have googled it and not found anything explaining how to do this or what it means.
My Project:
research data on sheet1. If there is an issue I want to click a button that will copy only the matching column data to a new row in a Specified sheet. From there the data will be reviewed and then another button to export the data to an MS SQL table.
ie:
Sheet1
A B C D E
ID CUR Region Amount Y/N
1 USD NA $54 Y
Sheet2
A B C D E
Region CUR Amount Type Misc
So if Column E = Y then copy all the relevant data in that row to a new sheet:
Sheet2 (output)
A B C D E
Region CUR Amount Type Misc
NA USD $54 Null Null
Sheet2 has columns not in Sheet1 and vice versa... Also the order of the columns are not the same in each sheet. The real sheets are huge with many columns and the row count will change everytime I refresh my data. I need this to loop until Col A in Sheet1 is null.
How do I store my headers in a string array?
A very practical way:
Dim hdlist As String
Dim sep As String
hdlist = "ID|CUR|Region|Amount|Y/N" ' Change this line
sep = "|"
Dim hdnames() As String
hdnames = Split(hdlist, sep, -1, vbBinaryCompare)
Then you can use a For loop to traverse the array.
Here's a piece of code that I've thrown together that I think meets your needs. I think the variable names are self explanatory, but if not, please follow up.
The code searches each cell in the header row of the origin sheet to see if it exists in the destination sheet. If so, it copies over the corresponding information.
Dim wsOrigin As Worksheet
Dim wsDest As Worksheet
Dim nCopyRow As Long
Dim nPasteRow As Long
Dim rngFnd As Range
Dim rngDestSearch As Range
Dim cel As Range
Const ORIGIN_ROW_HEADERS = 1
Const DEST_ROW_HEADERS = 1
Set wsOrigin = Sheets("Sheet1")
Set wsDest = Sheets("Sheet2")
nCopyRow = ActiveCell.Row
nPasteRow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS))
For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS))
On Error Resume Next
Set rngFnd = rngDestSearch.Find(cel.Value)
If rngFnd Is Nothing Then
'Do Nothing as Header Does not Exist
Else
wsDest.Cells(nPasteRow, rngFnd.Column).Value = wsOrigin.Cells(nCopyRow, cel.Column).Value
End If
On Error GoTo 0
Set rngFnd = Nothing
Next cel
Related
I have a simple macro that includes a dynamic array which fills up upon conditions are met. The data populates the macro as it is supposed to be functioning until it paste the data onto the spreadsheet. Now, all data is pasted correctly except for date values. Date values are pasted erroneously from European format to American format onto the spreadsheet (i.e. dd-mm-yyyy to mm-dd-yyyy). So for instance a 1st march 2019 becomes a 3rd January 2019 on the spreadsheet. Note that either I format beforehand the destination files or not, the problem still occurs.
The array has 14 columns and only column 12-13 are date values.
Edit Summary
Shredded the code from irrelevant information; added images of results.
Following is the code
Sub Verification()
Dim NewWorkbook As String, NewWorksheet As String
Dim wb As Workbook, sh As Worksheet
Dim LoopCounter As Long
Dim NewEntryCounter As Long
Dim Cols As Long, Rows As Long
Dim r As Range
Dim arr As Variant, NewEntry() As Variant
Dim myRange As Integer
NewWorkbook = LCase(InputBox("What is the name of the new report?"))
NewWorksheet = LCase(InputBox("What is the name of the sheet?"))
Set wb = ThisWorkbook
Set sh = wb.Sheets("Renouvellement")
Cols = Workbooks(NewWorkbook).Sheets(NewWorksheet).Range(Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1), Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1).End(xlToRight)).Count
Rows = sh.Range(sh.Cells(1, 1), sh.Cells(1, 1).End(xlDown)).Count
For Each r In Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A2", Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A1").End(xlDown))
If (r.Offset(0, 21).Text = "Red" Or r.Offset(0, 21).Text = "Blue") And r.Offset(0, 17).Value >= 24 Then
arr = Application.VLookup(r.Value, sh.Range("A:A"), 1, 0)
If IsError(arr) Then
NewEntryCounter = NewEntryCounter + 1
ReDim Preserve NewEntry(1 To Cols, 1 To NewEntryCounter)
For LoopCounter = 1 To Cols
NewEntry(LoopCounter, NewEntryCounter) = r.Offset(0, LoopCounter - 1)
Next LoopCounter
Else
End Sub
Sample results from Local window
Sample results when transferring date values onto spreadsheet
As you can see the first value inserted is changed when transferring data from vba to spreadsheet. The second value is correctly transferred. The third is not, and so on.
Again, it's a bit difficult for me to understand exactly what you're doing, but it seems that a filter might be simpler, so far as the copying of relevant data is concerned.
In your code, you are making multiple calls to the worksheet, and multiple Redim Preserve operations on the VBA array. Those operations can be costly.
Perhaps that part of the code could be simplified (and sped up) with something like (obviously, you may need to change the worksheet and range variables):
Set ws = Worksheets("sheet1")
Set r = ws.Range("a1").CurrentRegion
With r
.AutoFilter field:=22, Criteria1:="red", Operator:=xlOr, Criteria2:="blue"
.AutoFilter field:=18, Criteria1:=">=24"
End With
r.SpecialCells(xlCellTypeVisible).Copy
'Paste somewhere
ws.ShowAllData
I have been trying to put together the code for the following request, I am not an expert and I really need help on this, thanks in advance:
There are 2 sheets 1 "Database", 2 "Scorecard".
Loop through the rows in column C Database Sheet, each single value
will be copied into the Scorecard sheet Cell B3, this will change the
value of the cell C30.
The new value for cell C30 will then need to be copied back to the Database Sheet in new column "F", and this will be looped till the
last cell. Filling the list.
It requires to be correspondent to the the cell, thus the first value in C2 will need the matching value in F2 and so on.
The database will change in time so it requires a code that allows to consider new entrances.
I have tried to modify this code I've seen in a different question: Loops in VBA? I want to use a loop to select and copy till last cell but can't make it work...
Thanks so so much!
Sub LoopThroughColumnC()
Dim LastRowInColC As Long, Counter As Long
Dim SourceCell As Range, DestCell As Range
Dim MySheet As Worksheet
'set references up-front
Set MySheet = ThisWorkbook.Worksheets("Dati per calcolo")
Set CopySheet = ThisWorkbook.Worksheets("Scheda costo tessuto e capo")
With MySheet
LastRowInColC = .Range("C" & .Rows.Count).End(xlUp).Row
Set DestCell = ThisWorkbook.Worksheets("Scheda costo tessuto e capo").Range("B3")
End With
'loop through column C, copying from cells(counter, 11) to B3
With MySheet
For Counter = 1 To LastRowInColC
Set SourceCell = .Range("C" & Counter)
SourceCell.Copy Destination:=DestCell
If Target.Address = Range("A1").Address Then
' Get the last row on our destination sheet (using Sheet2, col A here)...
Dim intLastRow As Long
intLastRow = Sheet2.Cells(Sheet2.Rows.Count, "B").End(xlUp).Row
' Add our value to the next row...
Sheet2.Cells(intLastRow + 1, "A") = Target.Value
End If
Next Counter
End With
End Sub
I'm trying to fetch the data from an excel which contains a single query in each sheet.
so, here are my steps :
1) creating an excel application --> workbook --> worksheet objects
2) get all the sheet names and point to a specific sheet (which i'm doing harcoded for time being)
3) Retrieve all the rows from the sheet into an array of variants
4) finally join the each array variant into a single string
The final step i'm not able to achieve. when i'm using a for next loop i'm getting only 25 records into the string though the array has more than 25 elemets init or If I use join function for the array it's throwing a type mismatch error.
In my excel the query is always placed in multiple rows in first column itself.
To get the data into the array variable for the sheet names and actual query values i'm using a user defined push function. I want my arrays to grow dynamically based on the no. of the values.
please find my code below :
ReDim arrSheetNames(-1)
ReDim k(-1)
Dim strQry()
'create an excel application object
set myExcel =CreateObject("Excel.Application")
'create an excel workbook object
set myWorkBook=myExcel.WorkBooks.Open("D:\Test.xlsx")
'Get the sheetnames into an array
For i = 1 To myWorkBook.Sheets.Count
fnPush arrSheetNames, myWorkBook.Sheets.Item(i).Name
Next
'Get th second sheet of the excel
set mysheet = myworkbook.Worksheets(arrSheetNames(0))
'Get the max row occupied in the excel file
Row=mysheet.UsedRange.Rows.Count
'Get the max column occupied in the excel file
Col=mysheet.UsedRange.columns.count
'To read the data from the entire Excel file
For i= 1 to Row
For j=1 to Col
fnPush k,mysheet.cells(i,j).value
Next
Next
m = join (arrSheetNames)
msgbox m
this is where im getting only 25 rows added to the string however there are 33 elements in the array k.
i=0
'
For i = 0 To UBound(k) Step 1
n = n & k(i)
Next
msgbox n
when i'm using this statement it's throwing an error for type mismatch
strQry = join(k)
msgbox strQry
'Save the Workbook
'myExcel.ActiveWorkbook.Save
'Close the Workbook
myExcel.ActiveWorkbook.Close
'Close Excel
myExcel.Application.Quit
Set mysheet =nothing
Set myWorkBook = nothing
Set myExcel = nothing
sub fnPush(arr, var)
dim uba
uba = UBound(arr)
redim preserve arr(uba+1)
arr(uba+1) = var
end sub
The MsgBox function in VBScript can display a maximum of 1023 characters. I'm guessing you're reaching that limitation with your join() statement.
Replace Dim strQry() with Dim strQry, otherwise you should try to assign join result string to array that gives an error.
I have a horse show points spreadsheet where horses names and riders need to be matched up with the same pairs from other sheets. So, column 1 being the horse name, and column 2 being the rider name, I would like to display the point total from another sheet with the same horse/rider pair.
So, sheet1`row1 column 3 would need to find the same horse/rider pair (column a and b) from sheet 2 and display the point total (which is totaled in sheet2 column q of some row wherever that horse/rider pair is listed).
I'm not sure where to start with creating a formula like this. I did try with vlookup, but that doesn't seem to allow me to make an array of two columns and compare that with another array which I think is what I'm trying to do.
I think you may find the simplest solution (other than running a macro someone else has written for you of course) is to insert a column at the extreme left of both sheets and put something like =B2&" | "&C2 in Row2 of those columns (assumes your other columns have labels) then copy down and use a formula such as:
=IFERROR(VLOOKUP(A2,'Sheet 2'!A:R,18,FALSE),"")
(also in Row2 and copied down) to look up the points.
If you want to use VBA, you can insert a new module and copy this code in. Then you can use the function in a cell with =GetPointTotal(HorseCell, RiderCell)
Option Explicit
Function GetPointTotal(horseRange As Range, riderRange As Range)
Dim cell As Range, searchRange As Range
Dim displaySheet As Worksheet, pointSheet As Worksheet
Dim iEndRow As Integer
Dim horseCol As String, riderCol As String, pointCol As String, points As String
Dim b As Boolean
'Configuration
Set displaySheet = ThisWorkbook.Worksheets("Sheet1")
Set pointSheet = ThisWorkbook.Worksheets("Sheet2")
horseCol = "A"
riderCol = "B"
pointCol = "Q"
'EndConfiguration
iEndRow = pointSheet.Range(horseCol & 1).End(xlDown).Row
Set searchRange = pointSheet.Range(horseCol & 1 & ":" & horseCol & iEndRow)
b = False
For Each cell In searchRange
If b = True Then Exit For
If cell.Value2 = horseRange.Value2 Then
If cell.Offset(0, 1).Value2 = riderRange.Value2 Then
points = pointSheet.Range(pointCol & cell.Row).Value2
b = True
End If
End If
Next cell
GetPointTotal = points
End Function
I am developing a macro to eliminate blank rows from a worksheet which is used for entering customized orders. Lets say rows 7,8,9 and 12 have contents. I want to move the contents of row 12 to row 10.
So far I've located the last occupied row in column c then identified whether the cell in the row in column e is blank or not.
Now I want to put a value into an array either 0 (blank) or 1 (occupied). I am getting an error (object required) on the line of code that sets the value of stones (1) to 1 or 0.
What is going wrong?
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Belmont")
Set rng1 = ws.Columns("c").Find("*", ws.[c1], xlValues, , xlByRows, xlPrevious)
Dim zen As String
zen = rng1.Address(0, 0)
Range(zen).Select
Set ruby = Window.ActiveCell.Row - 11
Dim stones() As Boolean
ReDim stones(1 To ruby)
If IsEmpty(ActiveCell.Offset(2, 0)) Then
Set stones(1) = 0
Else
Set stones(1) = 1
End If
msg55 = MsgBox(stones(1), vbDefaultButton1, "Gekko")
My assumption is that you are doing this for purposes of learning rather than practicality:
You could google VBA arrays and get a plethora of material on the subject. I would start here:
http://www.cpearson.com/excel/vbaarrays.htm
You would declare your array like so:
Dim stones(1 To 10) As Double
You're going to have to iterate through each cell in your range. You can Google how to do that as well:
Loop through each cell in a range of cells when given a Range object
You can set the value of the 5th element in the array to the value of 10 like so:
stones(5) = 10
It really seems like you need to do some basic VBA programming tutorials. You could start here:
http://www.mrexcel.com/forum/excel-questions/667818-tutorials-excel-macros-visual-basic-applications.html
If you're trying to get rid of blank cells in sheet 'Belmont' column C, then this should work for you:
Sub tgr()
Dim rngBlanks As Range
With Sheets("Belmont").Range("C1", Sheets("Belmont").Cells(Rows.Count, "C").End(xlUp))
On Error Resume Next
Set rngBlanks = .SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngBlanks Is Nothing Then rngBlanks.EntireRow.Delete
End With
Set rngBlanks = Nothing
End Sub
If you want to delete all rows in which column C is blank, then:
Sub dural()
Dim r As Range
Set r = Range("C:C").Cells.SpecialCells(xlCellTypeBlanks).EntireRow
r.Delete
End Sub
will accomplish this without looping.