Related
I have a value in column C which in some cases are duplicated, where there are duplicates I want it to look in column Z for the corresponding ID if none exist I want it to check where whether any other values in column C have a value in Column Z and then add the missing values into column Z accordingly:
Column C Column Z
45519 Blank*
45519 1
456 2
456 *Blank
Expected result:
Column C: Column Z
45519 1
45519 1
456 2
456 2
Stackoverflow Code I have adapted to use 1 and 24 respectively.
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("C1:Z" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 2)
If Not IsEmpty(dataArr(currentRow, 2)) And Not dict.Exists(dataArr
(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 2)) Then
dataArr(currentRow, 2) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
I am receiving no result in column Z as a result of this
Try this. Amended column references as per comments, plus I think your first loop was unnecessarily long. You'll need to change the 24s if your array is actually of a different size.
Option Explicit
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("C1:Z" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If Not IsEmpty(dataArr(currentRow, 24)) And Not dict.Exists(dataArr(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 24)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 24)) Then
dataArr(currentRow, 24) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
Alternative method
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim r As Range, r1 As Range, s As String
For Each r In ws.Range("Z1:Z" & lastRow).SpecialCells(xlCellTypeBlanks)
Set r1 = ws.Range("C1:C" & lastRow).Find(ws.Cells(r.Row, "C"), , , xlWhole)
If Not r1 Is Nothing Then
s = r1.Address
Do Until r1.Row <> r.Row
Set r1 = ws.Range("C1:C" & lastRow).FindNext(r1)
If r1.Address = s Then Exit Do
Loop
r.Value = ws.Cells(r1.Row, "Z")
End If
Next r
End Sub
There is some tidying up to do. Currently assumes data starts in row 2.
Option Explicit
Public Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("transactions")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim unionRng As Range
Set unionRng = Union(ws.Range("C2:C" & lastRow), ws.Range("Z2:Z" & lastRow))
Dim dataArray()
Dim numberOfColumns As Long
numberOfColumns = unionRng.Areas.Count
ReDim dataArray(1 To lastRow, 1 To numberOfColumns) '1 could come out into variable startRow
Dim currRow As Range
Dim columnToFill As Long
For columnToFill = 1 To numberOfColumns
For Each currRow In unionRng.Areas(columnToFill)
dataArray(currRow.Row - 1, columnToFill) = currRow 'assume data starts in row 1 otherwise if 2 then currRow.Row -1 etc
Next currRow
Next columnToFill
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
If Not IsEmpty(dataArray(currentRow, 2)) And Not dict.Exists(dataArray(currentRow, 1)) Then
dict.Add dataArray(currentRow, 1), dataArray(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
If IsEmpty(dataArray(currentRow, 2)) Then
dataArray(currentRow, 2) = dict(dataArray(currentRow, 1))
End If
Next currentRow
ws.Range("Z2").Resize(UBound(dataArray, 1), 1) = Application.Index(dataArray, 0, 2)
End Sub
you could very simply go like follows
Option Explicit
Sub main()
Dim cell As Range, IdsRng As Range
With Worksheets("transactions") 'reference wanted sheet
Set IdsRng = .Range("Z2", .Cells(.Rows.Count, "Z").End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants, xlNumbers) 'get all IDs from its column Z cells with constant numeric value
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 'reference referenced sheet column C cells from row 1 (header) down to last not empty one
For Each cell In IdsRng 'loop through all IDs
.AutoFilter Field:=1, Criteria1:=cell.Offset(, -23).value ' filter referenced cells on 1st column with passed ID content 'filter referenced range with current ID
.Offset(1, 23).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value = IdsRng.value 'write all filtered cells corresponding values in column Z with current ID
Next
End With
.AutoFilterMode = False
End With
End Sub
The below is my code. I have tried many different solutions but none seem to work. Any help would be appreciated.
Sub MultiDimensiionArray1()
'array for sheet one and sheet two
Dim myArraySheet1(0 To 3, 0 To 4) As Variant
Dim myArraySheet2(0 To 5, 0 To 4) As Variant
Dim i As Long, j As Long ' dimension counter for for sheet one
Dim Dimension1 As Long, Dimension2 As Long ' dimension counter for for sheet one
'number of rows in sheet one
Dim x As Integer, NumRows As Integer
Sheet1.Activate
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
'store everything on sheet one in array
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
myArraySheet1(i, j) = Range("A2").Offset(i, j).Value
Next j
Next i
'store everything on sheet two in array
Sheet2.Activate
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
myArraySheet2(Dimension1, Dimension2) = Range("A2").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
'READ FROM ARRAY/OR DISPLAY THE RESULT
Sheet1.Activate
' Select sheet one cell G2
Range("G2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
'if sheet one row equal to sheet two row execute the below code
If myArraySheet1(i, j) = myArraySheet2(Dimension1, Dimension2) Then
ActiveCell.Value = "YES IT IS DUPE AND NOT RESOLVED"
ActiveCell.Interior.ColorIndex = 4
ActiveCell.Font.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = "Brand New"
ActiveCell.Interior.ColorIndex = 3
ActiveCell.Font.ColorIndex = 2
End If
Next Dimension2
Next Dimension1
Next j
Next i
Next
End Sub
I did not use array but the code below give you the expected output that you want:
Option Explicit
Sub Compare()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Lastrow As Long, Lastrow2 As Long
Dim i As Integer, j As Integer, c As Integer
Dim FOUND As Boolean
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
FOUND = False
For j = 2 To Lastrow2
For c = 1 To 5
If ws1.Cells(i, c).Value = ws2.Cells(j, c).Value Then
FOUND = True
Else
FOUND = False
Exit For
End If
Next c
If FOUND = True Then
ws1.Cells(i, 7) = "YES IT IS DUPE AND NOT RESOLVED"
Exit For
End If
Next j
If FOUND = False Then
ws1.Cells(i, 7) = "Brand new"
End If
i = i + 1
Loop While i < Lastrow + 1
End Sub
With this you'll have two arrays containing values of cells that aren't equal so you'll be able to use the values you need to do what you want
Sub Test()
Dim DiffSh1() As Variant
Dim DiffSh2() As Variant
Call Compare_Sheets(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Sheet2"), DiffSh1, DiffSh2)
'Now you can use the values in the two arrays as you need
For x = LBound(DiffSh1, 1) To UBound(DiffSh1, 1)
For y = LBound(DiffSh1, 2) To UBound(DiffSh1, 2)
If DiffSh1(x, y) <> "" Then
MsgBox ("Cell at Row " & x & " Column " & y & " isn't equal:" & vbCrLf & _
"Value in sheet1 is: " & DiffSh1(x, y) & vbCrLf & _
"Value in sheet2 is: " & DiffSh2(x, y))
End If
Next y
Next x
End Sub
Public Sub Compare_Sheets(ByVal Sh1 As Worksheet, ByVal Sh2 As Worksheet, ByRef DiffIn1() As Variant, ByRef DiffIn2() As Variant)
Dim LastCol
Dim LastRow
LastCol = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Column
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column > LastCol Then
LastCol = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column
End If
LastRow = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Row
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row > LastRow Then
LastRow = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row
End If
ReDim DiffIn1(1 To LastRow, 1 To LastCol)
ReDim DiffIn2(1 To LastRow, 1 To LastCol)
Dim mCol As Long, mRow As Long
For mCol = 1 To LastCol
For mRow = 1 To LastRow
If Sh1.Cells(mRow, mCol) <> Sh2.Cells(mRow, mCol) Then
DiffIn1(mRow, mCol) = Sh1.Cells(mRow, mCol).Value
DiffIn2(mRow, mCol) = Sh2.Cells(mRow, mCol).Value
Else
DiffIn1(mRow, mCol) = ""
DiffIn2(mRow, mCol) = ""
End If
Next mRow
Next mCol
End Sub
I got the following code, which is supposed to
1) Search for my word, copy and paste the entire row that contains the word into new sheet
2) Search for a word after the 1st, then copy and paste that entire row beside the contents of 1) in the new sheet.
Could someone take a look, I am having trouble actually getting the results, there is no error I am getting. So I assume it is the whole copy and paste to my new sheet name. However i am not 100% sure.
Sub stack()
Dim OSheet As String
Dim NSheet As String
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Sheet1" 'Old Sheet Name
NSheet = "Sheet7" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
End If
'If cell has "First Name then..."
Dim StrX As String
If InStr(LCase(Cells(i, 1)), LCase("stack:")) Then
StrX = Range(Cells(NSLRow + 1, 1), Cells(NSLRow + 1, 6)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("overflow:")) Then
StrX = Range(Cells(NSLRow + 1, 7), Cells(NSLRow + 1, 8)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
End If
Next i
End Sub
EDIT, Expected result:
!http://i.imgur.com/69elWuB.jpg
EDIT, updated code with some fixes you guys mentioned.
Sub stackv2()
'added Sheets(OSheets)to Range Cells
Dim OSheet As String
Dim NSheet As String
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Sheet1" 'Old Sheet Name
NSheet = "Sheet7" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
End If
'If cell has "First Name then..."
Dim StrX As String
If InStr(LCase(Cells(i, 1)), LCase("first name")) Then
StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 1), Sheets(OSheet).Cells(NSLRow + 1, 6)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 7), Sheets(OSheet).Cells(NSLRow + 1, 8)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
End If
Next i
End Sub
This will work for your example:
Sub stackv2()
Dim OSheet As Worksheet
Dim NSheet As Worksheet
Dim i As long
Dim LRow As long
Dim NSLRow As Long
Dim cpyClm As Long
Set OSheet = Sheets("Sheet1") 'change to your Old Sheet Name
Set NSheet = Sheets("Sheet7") 'change to your New Sheet Name
cpyClm = 1 'change this to the number columns desired
'Finds last row in the New Sheet
NSLRow = NSheet.Cells(NSheet.Rows.Count, 1).End(xlUp).Row
With OSheet
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
For i = 2 To LRow
'If cell has "First Name then..."
If InStr(LCase(.Cells(i, 1)), LCase("first name")) Then
NSLRow = NSLRow + 1 'moves to new row every time this is true.
NSheet.Cells(NSLRow, 1).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
NSheet.Cells(NSLRow, 1 + cpyClm).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("middle name")) Then
NSheet.Cells(NSLRow, 1 + (cpyClm * 2)).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
End If
Next i
End With
End Sub
But because we don't know what your true data looks like I put the ability to change the number of columns to copy. Also since your example does not include column A, and your explanation wants it you will need to change the column in the cells to 1 instead of 2
If this does not work or help you figure out how to adjust it on your own, you will need to post an actual representation of your data and desired output.
OK, I've got a straight-forward 2-d block of data in excel: row 1 and column 1 are labels, the rest are numbers. My task right now is to put the sum of each column in the first empty cell(row) underneath.
Whereas my practice dataset is of known dimensions, the actual datasets I'll be using this program on will have a variable number of rows and columns. To this end, I can't just say "=SUM(B2:B20)" because the last filled cell won't always be B20 (for example). The easiest way to total each column, I thought, would be a FOR..NEXT loop, but I just can't get VS to accept the summation formula. Here's what I've got so far:
`With xlWsheet2 'check for last filled row and column of transposed data'
If xlApp.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow2 = .Cells.Find(What:="*",
After:=.Cells(1, 1),
LookAt:=Excel.XlLookAt.xlPart,
LookIn:=Excel.XlFindLookIn.xlFormulas,
SearchOrder:=Excel.XlSearchOrder.xlByRows,
SearchDirection:=Excel.XlSearchDirection.xlPrevious,
MatchCase:=False).Row
Else : lRow2 = 1
End If
If xlApp.WorksheetFunction.CountA(.Cells) <> 0 Then
lCol2 = .Cells.Find(What:="*",
After:=.Range("A1"),
LookAt:=Excel.XlLookAt.xlPart,
LookIn:=Excel.XlFindLookIn.xlFormulas,
SearchOrder:=Excel.XlSearchOrder.xlByRows,
SearchDirection:=Excel.XlSearchDirection.xlPrevious,
MatchCase:=False).Column
Else : lCol2 = 1
End If
lastcell2 = xlWsheet2.Cells(lRow2, lCol2) 'defines last row, column of transposed data'
emptyRow1 = xlWsheet2.Rows(lRow2).Offset(1) 'defines the first empty row'
'add in cell of SUM underneath each column'
For i As Integer = 2 To lCol2
colTop = xlWsheet2.Cells(2, i)
colBot = xlWsheet2.Cells(lRow2, i)
ELtotal = xlWsheet2.Range(emptyRow1, i)
ELtotal = .Sum(.Range(colTop, colBot))
Next i
End With
`
Now, the ELtotal statements used to be one long line, but I was trying to see what part VS had a problem with. It breaks at the first one, .Range(emptyRow1, i). Here's other iterations of that equation I've tried that weren't accepted:
.Range(emptyRow1, I).Formula = "=SUM(colTop, colBot)"
.Range(emptyRow1, I).Formula = "=SUM(.cells(2,i), (lRow2,i))"
.Range(emptyRow1, I).Formula = .sum(.range(colTop, colBot)
.Range(emptyRow1, I).Value = etc...
ad inifintum
PS- I'm pretty new to this, so I'm probably going about this whole process the wrong way...
Based on what you told me about the row and column headings, I believe that this code will do what you want, namely put a single column sum in the first empty cell underneath.
Sub find()
Dim lastrow As Long, lastcol As Long, thiscol As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For thiscol = 2 To lastcol
Cells(lastrow + 1, thiscol).Select
ActiveCell.Value = WorksheetFunction.Sum(Range(Cells(1, ActiveCell.Column), ActiveCell))
Next
End Sub
Best of luck.
This formula will do the trick of summing two whole columns, A and B in this case:
= sum($A:$B)
If it is possible for the headers to be interpreted as numeric values that might contribute to the sum then the formula should be amended to be
= sum($A:$B) - sum($A$1:$B$1)
In order to export to excel with sum of all numeric columns from DataGridView, add a button to your form and add the following code in its click event:-
Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button4.Click
'--- Export to Excel -------------------------------------------------
Dim xlApp As Excel.Application
Dim xlWorkBook As Excel.Workbook
Dim xlWorkSheet As Excel.Worksheet
Dim misValue As Object = System.Reflection.Missing.Value
Dim i As Integer
Dim j As Integer
Dim datarange As Excel.Range
Dim save_file As New SaveFileDialog
'give its extension
''save_file.Filter = "xls files (*.xls)|*.xls|All files (*.*)|*.*"
'save_file.Filter = "xls files (*.xls)|*.xls"
save_file.Filter = "xls files (*.xls)|*.xls|Excel 2007|*.xlsx"
''Select xls
save_file.FilterIndex = 2
save_file.FileName = "My_excel_report_"
save_file.RestoreDirectory = True
Try
If save_file.ShowDialog() = DialogResult.OK Then
xlApp = New Excel.ApplicationClass
xlWorkBook = xlApp.Workbooks.Add(misValue)
xlWorkSheet = xlWorkBook.Sheets("sheet1")
For x = 0 To DataGridViewSummary1.ColumnCount - 1
xlWorkSheet.Cells(0 + 1, x + 1) = _
DataGridViewSummary1.Columns(x).HeaderText
Next
For i = 0 To DataGridViewSummary1.RowCount - 1
For j = 0 To DataGridViewSummary1.ColumnCount - 1
If IsDate(DataGridViewSummary1(j, i).Value) Then
'MsgBox("The cell value is date")
xlWorkSheet.Cells(i + 2, j + 1) = FormatDateTime(CDate(DataGridViewSummary1(j, i).Value.ToString), DateFormat.ShortDate)
xlWorkSheet.Cells(i + 2, j + 1).HorizontalAlignment = Excel.Constants.xlCenter
xlWorkSheet.Cells(i + 2, j + 1).VerticalAlignment = Excel.Constants.xlCenter
Else
xlWorkSheet.Cells(i + 2, j + 1) = _
DataGridViewSummary1(j, i).Value.ToString()
End If
Next
Next
datarange = xlWorkBook.ActiveSheet.UsedRange
datarange.Font.Name = "Consolas"
datarange.Font.Size = 10
'--- added on 07/09/2016 -------------------------------------------------------------------
Dim lastrow, lastcol As Long
With xlWorkSheet
lastcol = .Cells(1, .Columns.Count).End(Excel.XlDirection.xlToLeft).Column
lastrow = .Range("A" & .Rows.Count).End(Excel.XlDirection.xlUp).Row
End With
'MessageBox.Show("The last column in Sheet1 which has data is " & lastcol)
'MessageBox.Show("The last row in Col A of Sheet1 which has data is " & lastrow)
For i = 2 To lastcol
If IsNumeric(xlWorkSheet.Cells(lastrow, i).Value) Then
xlWorkSheet.Cells(lastrow + 1, i).Select()
xlWorkSheet.Cells(lastrow + 1, i).Value = xlApp.WorksheetFunction.Sum(xlWorkSheet.Range(xlWorkSheet.Cells(1, i), xlWorkSheet.Cells(lastrow + 1, i)))
End If
Next i
xlWorkSheet.Columns.AutoFit()
'----------------------------------------------------------------------------------------------
xlWorkSheet.SaveAs(save_file.FileName) 'sd.filename reurns save file dialog path
xlWorkBook.Close()
xlApp.Quit()
releaseObject(xlApp)
releaseObject(xlWorkBook)
releaseObject(xlWorkSheet)
'--------------------------------------
Dim proc As Process = Nothing
Dim startInfo As New ProcessStartInfo
startInfo.FileName = "EXCEL.EXE"
startInfo.Arguments = save_file.FileName
Process.Start(startInfo)
End If
Catch ex As Exception
MessageBox.Show(ex.ToString)
'GlobalErrorHandler(ex)
End Try
End Sub
I currently have an array which I populate and paste in a sheet named "T1" using a macro. My current macro uses the rowcount function to determine the used rows and pastes the array from the next available row.
The problem I am having is that when I paste this array multiple times, the arrays need to be spaced by a row so that i can differentiate different submissions. This is what I have so far, and I was hoping someone could help me with this:
Sub CopyData()
Dim Truearray() As String
Dim cell As Excel.Range
Dim RowCount1 As Integer
Dim i As Integer
Dim ii As Integer
Dim col As Range
Dim col2 As Range
i = 0
ii = 2
RowCount1 = DHRSheet.UsedRange.Rows.Count
Set col = DHRSheet.Range("I1:I" & RowCount1)
For Each cell In col
If cell.Value = "True" Then
Dim ValueCell As Range
Set ValueCell = Cells(cell.Row, 3)
ReDim Preserve Truearray(i)
Truearray(i) = ValueCell.Value
Dim siblingCell As Range
Set siblingCell = Cells(cell.Row, 2)
Dim Siblingarray() As String
ReDim Preserve Siblingarray(i)
Siblingarray(i) = DHRSheet.Name & "$" & siblingCell.Value
i = i + 1
End If
Next
Dim RowCount2 As Integer
RowCount2 = DataSheet.UsedRange.Rows.Count + 1
For ii = 2 To UBound(Truearray)
DataSheet.Cells(RowCount2 + ii, 2).Value = Truearray(ii)
Next
For ii = 2 To UBound(Siblingarray)
DataSheet.Cells(RowCount2 + ii, 1).Value = Siblingarray(ii)
Next
DataSheet.Columns("A:B").AutoFit
MsgBox ("Data entered has been successfully validated & logged")
End Sub
If you Offset two rows from the bottom cell, you will leave a blank row of separation. You should also consider filling the whole array as base 1 and writing it to DataSheet in one shot.
Sub CopyData2()
Dim rCell As Range
Dim aTrues() As Variant
Dim rRng As Range
Dim lCnt As Long
'Define the range to search
With DHRSheet
Set rRng = .Range(.Cells(1, 9), .Cells(.Rows.Count, 9).End(xlUp))
End With
'resize array to hold all the 'trues'
ReDim aTrues(1 To Application.WorksheetFunction.CountIf(rRng, "True"), 1 To 2)
For Each rCell In rRng.Cells
If rCell.Value = "True" Then
lCnt = lCnt + 1
'store the string from column 2
aTrues(lCnt, 1) = DHRSheet.Name & "$" & rCell.Offset(0, -7).Value
'store the value from column 3
aTrues(lCnt, 2) = rCell.Offset(0, -6).Value
End If
Next rCell
'offset 2 from the bottom row to leave a row of separation
With DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Offset(2, 0)
'write the stored information at one time
.Resize(UBound(aTrues, 1), UBound(aTrues, 2)).Value = aTrues
End With
End Sub