How to copy a reusable multi row/column table from one excel worksheet to a database on another worksheet - excel

I'm reasonably new to VBA coding and I was wondering if it is possible to do the following?
I have a reusable input worksheet that contains, amongst other elements, a table that has 24 columns and 10 rows. I'd like to be able to add however many rows have been completed into a database on another worksheet.
I've managed to find some code that allows for single row updating but no success for multiple rows.
Any suggestions would be much appreciated.
Thanks
Iain
The code looks like this:
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim lRsp As Long
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("PartsData")
oCol = 3 'order info is pasted on data sheet, starting in this column
'check for duplicate order ID in database
If inputWks.Range("CheckID") = True Then
lRsp = MsgBox("Order ID already in database. Update record?", vbQuestion + vbYesNo, "Duplicate ID")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change Order ID to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("OrderEntry")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
'mandatory fields are tested in hidden column
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
'enter date and time stamp in record
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
'enter user name in column B
.Cells(nextRow, "B").Value = Application.UserName
'copy the order data and paste onto data sheet
myCopy.Copy
.Cells(nextRow, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
ClearDataEntry
End If
End Sub
And the input table is attachedenter image description here

Example code in response to comment:
Dim lr as long, lc as long, lr2 as long
with ThisWorkbook.Sheets("Source")
lr = .cells(.rows.count,1).end(xlup).row
lc = .cells(1,.columns.count).end(xltoleft).column
.range(.cells(2,1),.cells(lr,lc)).copy
end with
with Workbooks("Database").Sheets("Dest")
lr2 = .cells(.rows.count,1).end(xlup).row
.cells(lr2+1,1).pastespecial xlvalues
end with

Related

How to move a data set from one sheet to another based on criteria using VBA

I am trying to move data from one Table called Raw_Data on sheet Raw Data to another table called Phone_Number on sheet No Quality.
I have 16 columns on the tables and I need to confirm if the Raw Data table has the words No Quality or PH Phone on the 15th column. If it does then I want to move the data to the No Quality sheet and paste it into the table there. Once it is pasted I want to erase the data off of the Raw Data table.
I have tried a few different methods but can't seem to get them to work. Here is the first method I'm using
Sub Numbers()
Dim dataSheet As Worksheet, newSheet As Worksheet
Dim dataTable As ListObject, newTable As ListObject
Dim dataCount As Long
Dim checkOne As String, checkTwo As String
Dim copyRange As Range
Set dataSheet = Worksheets("Raw Data")
Set newSheet = Worksheets("No Quality")
Set dataTable = dataSheet.ListObjects("Raw_Data")
Set newTable = newSheet.ListObjects("Phone_Number")
checkOne = "PH Phone"
checkTwo = "No Quality"
dataCount = dataSheet.ListObjects("Raw_Data").ListRows.Count
dataValue = dataSheet.ListObjects("Raw_Data").DataBodyRange(dataCount, "O").Value
dataLocation = dataSheet.ListObjects("Raw_Data").DataBodyRange(dataCount, "O").row - 1
For i = 2 To dataLocation
valueToCheck = dataSheet.ListObjects("Raw_Data").DataBodyRange(i, "O")
If valueToCheck = checkOne Or valueToCheck = checkTwo Then
'Errors out on the line below
Worksheets("Raw Data").Range(Cells(i, "A"), Cells(i, "P")).Copy
Worksheets("No Quality").Cells(Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row, 1).PasteSpecial
End If
Next i
End Sub
I can get it to partially run but it will never complete. I attempted to use the following code but I'm not sure how to change it to run in the way that I needed it.
Sub NoQuality()
Dim dataTable As Range
Dim newTable As Range
Application.ScreenUpdating = False
Set dataTable = Worksheets("Raw Data").ListObjects("Raw_Data").DataBodyRange
Set newTable = Worksheets("No Quality").ListObjects("Phone_Number").DataBodyRange
dataTable.Copy newTable.Offset(tbl2.Rows.Count)
Application.CutCopyMode = False
tbl1.ClearContents
Application.ScreenUpdating = True
End Sub
Results of New Code
You could probably get away with a lot less code. Please try the following & let me know how it goes.
Option Explicit
Sub Numbers()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Raw Data")
Set ws2 = Sheets("No Quality")
With ws1.ListObjects("Raw_Data").Range
.AutoFilter 15, "No Quality", 2, "PH Phone"
.Offset(1).Resize(.Rows.Count - 1).Copy ws2.Cells(2, 1)
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
ws1.ListObjects("Raw_Data").AutoFilter.ShowAllData
End With
End Sub

Excel VBA Looping through Worksheets and Copy Paste into a different Worksheet

I am new to VBA and I am trying to write some code to copy data from one worksheet to another one. I have checked various sites and tried to write the code, but until I always get an error. The setting is as follows:
I have various worksheets, most of them are worksheets based on different teams (I will call them Team-Worksheets), one sheet is the data I import from an external databank (I will call it Import-Worksheet).
The code should loop through all the Team-Worksheets and based on the Name of the Team, which is always located in Cell “A2” it should find all stories that belong to the team in the “Import-Worksheet”(comparing it with “Team Name Column”) and ONLY copy the “ID” located in the “ID Column” and paste it into the second row of “ID Column” of the ListObject 1 of the corresponding "Team-Worksheet". Then it should find the next ID of that Team in the “Import-Worksheet” and copy-paste it into the next row of ListObject 1(all sheets have multiple listobjects, with varying length and start points). After it went through all the rows it should continue with the next “Team-Worksheet”.
I am unsure if I should run a 1) "for-loop" + "for-loop" 2) “for-loop” + an “advanced-filter”, or 3) “for-loop” + “for-loop combined with index/match”?
I used if B4 = Epic Id Link as I don't want to apply this to all the worksheets
Example 1:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim x As Long
Dim y As Worksheet
Dim rw As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
i = sht.Range("A2")
Set y = ActiveSheet
If sht.Range("B4").Value = "EPIC ID Link" Then
Sheets("Jira Import").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 5 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 19).Value
If ThisValue = i Then
Cells(x, 4).Copy
y.ListObjects(1).ListColumns("US ID").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Jira Import").Select
End If
Next x
End If
Next sht
Application.ScreenUpdating = True
End Sub
Example 2:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim rgData As Range, rgCriteria As Range, rgOutput As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
Set i = ActiveSheet.Range("A2")
If sht.Range("B4").Value = "EPIC ID Link" Then
Set rgData = ThisWorkbook.Worksheets("Jira Import").Range("S5").CurrentRegion
Set rgCriteria = i
Set rgOutput = ActiveSheet.ListObjects(1).ListColumns("US ID").DataBodyRange
rgData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rgOutput, Unique:=True
End If
Next sht
Application.ScreenUpdating = True
End Sub
Solving this would save me plenty of manual work!

VBA Script to Delete Column Values based on other Column Values

I'm looking for a VBA code to as the title specifies, delete data based on conditions
So I have Column A and Column B, Rows starts from 2 until the end of the sheet, so as an example If the value in B2 is "OK", I would like for the value in A2 to be cleared and then loop the same process until the end of both columns, this is what I have so far but it's not working properly:
Sub Clear()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Loop through range
For i = 2 To myLastRow
If Cells(i, "B").Value = "OK" Then Range(Cells(i, "A")).ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Quick fix for your code is to remove Range
Sub Clear()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
'Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
' Loop through range
For i = 2 To myLastRow
' If Cells(i, "B").Value = "OK" Then Range(Cells(i, "A")).ClearContents
If Cells(i, "B").Value = "OK" Then Cells(i, "A").ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Pay attention as Cells refers to the active sheet. In case you would like to run the code on a specific sheet you should better specifiy the sheet.

How to create a textjoin worksheet function with dynamic range

I have data where I have many column headers. One of the header is "Text" and one other header is "Value Date". I want to combine the values contained in every row between these columns in another column row-wise.
The problem is the number of columns between these two headers is not constant. It changes with every new ledger I export. So I want my code to be dynamic in such a way that it will identify the column of "Text" and then it will identify the column of "Value Date" and combine everything between in another column row-wise.
This is where I have reached with my code but I don't know why it's not working. I have been trying this for last 3 days only to get nowhere. When I run this code, the result which I get is "TextColumnNo:ValueColumnNo".
Sub TextJoin()
Dim TextColumnNo As Range
Dim ValueColumnNo As Range
Range("A1").Select
ActiveCell.EntireRow.Find("Text").Activate
Set TextColumnNo = Range(ActiveCell.Address(False, False))
Range("A1").Select
ActiveCell.EntireRow.Find("Value").Activate
Set ValueColumnNo = Range(ActiveCell.Address(False, False))
ActiveCell.Offset(1, -1).Select
Application.CutCopyMode = False
ActiveCell.Value = Application.WorksheetFunction.TextJoin(" ", True, _
"TextColumnNo:ValueColumnNo")
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A8524")
ActiveCell.Range("A1:A8524").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
You would need 2 loops for this. One looping through all rows and one looping through the columns to combine the text for each row.
Note that you need to adjust some things like sheet name and output column here.
Option Explicit
Public Sub TextJoin()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1") 'define a worksheet
'find start
Dim FindStart As Range
Set FindStart = ws.Rows(1).Find("Text")
If FindStart Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find end
Dim FindEnd As Range
Set FindEnd = ws.Rows(1).Find("Value Date")
If FindEnd Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find last used row in column A
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 2 To lRow 'loop through all rows (2 to last used row)
Dim CombinedText As String
CombinedText = vbNullString 'initialize/reset variable
Dim iCol As Long 'loop through columns for each row (from start to end column)
For iCol = FindStart.Column To FindEnd.Column
CombinedText = CombinedText & ":" & ws.Cells(iRow, iCol).Text 'combine values
Next iCol
ws.Range("Z" & iRow) = CombinedText 'write values in column Z
Next iRow
End Sub
Sub TextJoin()
Dim ColRefText As Long
Dim ColRefValueDate As Long
Const firstcol = "Text"
Const secondcol = "Value Date"
Dim r As Range
Set r = Rows(1).Cells.Find(firstcol)
If Not r Is Nothing Then
ColRefText = r.Column
Set r = Rows(1).Cells.Find(secondcol)
If Not r Is Nothing Then
ColRefValueDate = r.Column
End If
End If
If ColRefValueDate + ColRefText > 0 Then
With Cells(2, Worksheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
.Formula = Replace("=" & Cells(2, ColRefText).AddressLocal & "&" & Cells(2, ColRefValueDate).AddressLocal, "$", "")
.Copy Range(.Address, Cells(ActiveSheet.UsedRange.Rows.Count, .Column).Address)
End With
End If
End Sub

Copy rows in Excel if cell contains name from an array

I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub

Resources