Periodically Copying Concatenated Data in Excel To Second Sheet While Primary Sheet Remains Active for Data Entry - vba

I am pulling data from various cells on Sheet1 in Excel and copying the values to specific cells on a row in Sheet2 every specified period of time. I almost have my project completed but am unable to copy concatenated data in the same manner. How would I incorporate the following excel statement into my code for the data to be copied on sheet2 from sheet1? The output should go into cell AB on Sheet2.
Not to confuse the issue but the reason the code is done in this manner is so that data can be entered on sheet 1 which will be the active sheet on the screen at all times but data will be periodically be saved to sheet2.
Excel Statement i need to incorporate and output to Cell "AB" on sheet2:
=CONCATENATE(Sheet1!I9,", ",Sheet1!I10,", ",Sheet1!I11,", ",Sheet1!I12)
Current Code:
Option Explicit
Public dTime As Date
Sub ValueStore()
Dim dTime As Date
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Set ws2 = ActiveWorkbook.Worksheets("Sheet2")
Dim lRow As Long
lRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
With ws2
Range("X1:X" & lRow).Offset(1).Value = ws1.Range("F15").Value
Range("Y1:Y" & lRow).Offset(1).Value = ws1.Range("F14").Value
Range("Z1:Z" & lRow).Offset(1).Value = ws1.Range("F17").Value
Range("AA1:AA" & lRow).Offset(1).Value = ws1.Range("F16").Value
End With
StartTimer1
End Sub
Sub StartTimer1()
dTime = Now + TimeValue("00:00:05")
Application.OnTime dTime, "ValueStore", Schedule:=True
End Sub
Sub StopTimer1()
On Error Resume Next
Application.OnTime dTime, "ValueStore", Schedule:=False
End Sub

Try this:
Sub ValueStore()
Dim dTime As Date, rw As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Set ws2 = ActiveWorkbook.Worksheets("Sheet2")
'find the next empty row on ws2
Set rw = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow
With rw
' note the .Range() here is *relative* to rw
.Range("A1").Value = Now '<< ensure a value is placed in colA....
.Range("X1").Value = ws1.Range("F15").Value
.Range("Y1").Value = ws1.Range("F14").Value
.Range("Z1").Value = ws1.Range("F17").Value
.Range("AA1").Value = ws1.Range("F16").Value
'method1 (contiguous vertical range)
.Range("AB1").Value = Join(Application.Transpose(ws1.Range("I9:I12").Value), ", ")
'method2 (join individual cells)
.Range("AB1").Value = Join(Array(ws1.Range("I9"), ws1.Range("I10"), _
ws1.Range("I11"), ws1.Range("I12")), ", ")
End With
StartTimer1
End Sub

Related

VBA Cut entire row based on text in cell and paste to new sheet

I am attempting to have VBA scan cells in column DQ for a specific text value of "AcuteTransfer" and then to cut the row containing that cell and past into the first available row of a new sheet.
This value would be listed multiple times and each listing would need to be cut and pasted over
sheet containing the cell is "adds&reactivates" and sheet where row would be pasted to is "ChangeS".
Any recommendations would be amazing.
So far I have
Sub ohgodwhathaveIdone()
Dim endRow As Long
Dim Match1() As Variant
Dim ws As Worksheet
Set ws = Worksheets("adds&reactivates")
ICount = 0
endRow = Sheets("adds&reactivates").Range("DQ999999").End(xlUp).Row
Match1 = Sheet1.Range("DQ2:DQ" & endRow)
For I = LBound(Match1) To UBound(Match1)
If Match1(I, 1) = "AcuteTransfer" Then
Sheets("adds&reactivates").Cells(I, "A").EntireRow.Copy Destination:=Sheets("changes").Range("A" & Sheets("Changes").Rows.Count).End(xlUp).Offset(1)
Else
End If
Next I
End Sub
Try this out - this is assuming both pages have headers on row 1.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("adds&reactivates")
Set sht2 = ThisWorkbook.Worksheets("ChangeS")
For i = 2 To sht1.Cells(sht1.Rows.Count, "DQ").End(xlUp).Row
If sht1.Range("DQ" & i).Value = "AcuteTransfer" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "DQ").End(xlUp).Row + 1)
End If
Next i
End Sub

Vba copy row to another workbook based on condition

I have 2 wb and need to copy value to another wb based on condition:
If the value in the column F of wb2 appears in column F of wb1, then I need to copy value in the column G of wb2 to column G of wb1. The code is below:
Dim LtRow As Long
Dim m As Long, n As Long
With wb2.Worksheets.Item(1)
LtRow = .Cells(.Rows.Count, "G").End(xlUp).Row
End With
With ThisWorkbook.Sheets.Item(2)
n = .Cells(.Rows.Count, "G").End(xlUp).Row + 1
End With
For m = 1 To LtRow
With wb2.Worksheets.Item(1)
If .Cells(m, 6).Value = ThisWorkbook.Sheets.Item(2).Cells(m, 6).Value Then
.Rows(m).Copy Destination:=ThisWorkbook.Sheets.Item(2).Range("G" & n)
n = n + 1
End If
End With
Next m
I don't know why the code didn't work at all! Where is the problem in my code?
EDIT:
To see what your excel files look like wasn't an option for what you are trying to do. Especially because in you have many empty rows. Anyway, this works for me:
Sub CopyConditions()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim Wb1Ws2 As Worksheet
Dim Wb2Ws1 As Worksheet
Set Wb1 = ThisWorkbook
Set Wb1Ws2 = ThisWorkbook.Sheets("Differences")
'open the wb2
Dim FullFilePathAndName As Variant
Dim StrOpenFileTypesDrpBx As String
Let StrOpenFileTypesDrpBx = "xls (*.xls),*.xls,CSV (*.CSV),*.CSV,Excel (*.xlsx),*.xlsx,OpenOffice (*.ods),*.ods,All Files (*.*),*.*,ExcelMacros (*.xlsm),.xlsm"
Let FullFilePathAndName = Application.GetOpenFilename(StrOpenFileTypesDrpBx, 1, "Compare this workbook ""(" & Wb1.Name & ")"" to...?", , False) 'All optional Arguments
If FullFilePathAndName = False Then
MsgBox "You did't select a file!", vbExclamation, "Canceled"
Exit Sub
Else
Set Wb2 = Workbooks.Open(FullFilePathAndName)
Set Wb2Ws1 = Wb2.Sheets("Sheet1")
End If
Dim rCell As Range
Dim sCell As Range
'loop through each cell in column F until row30 because with the empty cells in the column we can't use Rows.count
For Each rCell In Wb1Ws2.Range(Wb1Ws2.Cells(1, 6), Wb1Ws2.Cells(30, 6)) 'Wb1Ws2.Cells(Wb1Ws2.Rows.Count, 6).End(xlUp))
'if the cell column F is equal to a cell in wb2 sheet1 column L
For Each sCell In Wb2Ws1.Range(Wb2Ws1.Cells(3, 12), Wb2Ws1.Cells(Wb2Ws1.Rows.Count, 12).End(xlUp))
If sCell = rCell Then
rCell.Offset(0, 1) = sCell.Offset(0, 1)
End If
Next sCell
Next rCell
End Sub
How does it go for you?

Use value from column in one workbook to search column in another workbook

I'm having trouble with the code below.
I'm trying to use the values from column "A" in wb2 to search in column "G" in wb1.
Column "A" in wb2 contains a long list of numbers and I'm trying to search a exact match of that number in column "G" in wb1.
When there's a match I need it to set the value of column "AF" at the correct row in wb2 to the corresponding match from wb1, but from another column, maybe column "Z" instead of "G".
The to workbooks are already open, when running the macro.
Hope you can help me out.
Thanks in advance.
Sub ROAC()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim y As Integer
Dim sht As Worksheet
Set wb1 = Workbooks("EP_BB_DK_ny.xlsm")
Set wb2 = Workbooks("Laaneoversigt.xlsm")
Set sht = wb2.Worksheets("oversigt")
LastRow = sht.Cells(sht.Rows.Count, "AF").End(xlUp).Row
LastRowWb1 = wb1.Sheets("Period").Range(wb1.Sheets("Period").Range("G1"), wb1.Sheets("Period").Range("G1").End(xlDown)).Rows.Count
LastRowWb2 = wb2.Sheets("Oversigt").Range(wb2.Sheets("Oversigt").Range("A1"), wb2.Sheets("Oversigt").Range("A1").End(xlDown)).Rows.Count
For y = 7 To LastRowWb1
For x = 1 To LastRowWb2
If wb1.Sheets("Period").Range("G" & y).Value = wb2.Sheets("Oversigt").Range("A" & x).Value Then
wb2.Sheets("Oversigt").Range("AF" & LastRow).Offset(1, 0).Value = wb1.Sheets("Period").Range("G" & y)
End If
Next x
Next y
End Sub
Here's how I would look to carry out your requirement (assuming I understood it clearly enough anyway!). This code loops through all rows in column A in wb2, and performs a Find operation against column G in wb1. Where it's found, it sets AF column in wb2 for that row to be the value from wb1's Z column on the same row.
Sub ROAC()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim y As Integer
Dim sht As Worksheet
Set wb1 = Workbooks("EP_BB_DK_ny.xlsm")
Set wb2 = Workbooks("Laaneoversigt.xlsm")
Set wb1sht = wb1.Worksheets("Period")
Set wb2sht = wb2.Worksheets("oversigt")
LastRowWb1 = wb1sht.Cells(wb1sht.Rows.Count, "G").End(xlUp).Row
LastRowWb2 = wb2sht.Cells(wb2sht.Rows.Count, "A").End(xlUp).Row
For y = 1 To LastRowWb2
findMe = wb2sht.Range("A" & y).Value
With wb1sht.Range("G7:G" & LastRowWb1)
Set oFound = .Find(findMe)
If Not oFound Is Nothing Then
' Found number - set AF in wb2 on this row to Z on the same row from wb1
wb2sht.Range("AF" & oFound.Row).Value = wb1sht.Range("Z" & oFound.Row).Value
Else
' Didn't find number, so do whatever you might need to do to handle this in here...
End If
End With
Next
End Sub
This should fix your issue ( I've not wrote this in VBA so there might be the odd syntax issue).
Essentially, you can 'Find' your value in wb1 and if its there paste that value into wb2.
Sub ROAC()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim y As Integer
Dim sht As Worksheet
Dim fndRange as Range
Dim wb1Value as variant
Set wb1 = Workbooks("EP_BB_DK_ny.xlsm")
Set wb2 = Workbooks("Laaneoversigt.xlsm")
Set sht = wb2.Worksheets("oversigt")
LastRow = sht.Cells(sht.Rows.Count, "AF").End(xlUp).Row
LastRowWb1 = wb2.Sheets("Period").Range("G" & Rows.Count).End(xlUp).Row
LastRowWb2 = wb2.Sheets("Oversigt").Range("A" & Rows.Count).End(xlUp).Row
For y = 7 To LastRowWb1
wb1Value = wb1.Sheets("Period").Range("G" & y).Value
Set fndRange = wb2.Sheets("Oversigt").Range("A1:A" & LastRowWb2).Find(What:= wb1Value)
If Not fndRange is Nothing Then
wb2.Sheets("Oversigt").Range("AF" & LastRow).Offset(1, 0).Value = wb1.Sheets("Period").Range("G" & fndRange.Row)
End If
Next y
End Sub
Sub ROAC()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Target_Data As Range
Dim y As Integer
'Since you were using same sheets over and over, I just set ws1 and ws2
'instead of writing Wb1.Sheets("Period") wb2.Sheets("Oversigt") everytime
Set ws1 = Workbooks("EP_BB_DK_ny.xlsm").SHEETS("Period")
Set ws2 = Workbooks("Laaneoversigt.xlsm").SHEETS("Oversigt")
lastrow = ws2.Cells(ws2.Rows.Count, "AF").End(xlUp).Row
LastRowWb1 = ws1.Range(ws1.Range("G1"), ws1.Range("G1").End(xlDown)).Rows.Count
For y = 7 To LastRowWb1
''''This compares ws1.Range("G" & y) with ws2.Column A and set Target_Data as matching range
Set Target_Data = ws2.Columns("A").Find(ws1.Range("G" & y).Value)
''''This check if the Target_data found data or not (Find method will return Nothing if it doesn't find it.)
If Not (Target_Data Is Nothing) Then
''''''''This will write ws1. Column Z's data to ws2. Column AF on same row as where the data is found
ws2.Range("AF" & Target_Data.Row) = ws1.Range("Z" & y)
End If
Next y
End Sub
I might be little off on getting source data and target data.
It's really confusing
Anyway, You can play around with it to make it work :)

Excel VBA - Copy Sheet to new workbook X times

I need to copy the same worksheet X times (x = sheet2 row A) into a new workbook.
For each copy I need to:
1.Change a drop down to display the next value
2.Do a Refresh (Workbook is connected to a database which pulls different information based on the value of the drop down and is not automatically refreshed)
3.Copy just the values (no formulas)
Rename the sheet to the value of the drop down.
Save all of the copied worksheets into 1 workbook
My code (below) which is called on a button press currently saves the sheet X times based on sheet2 rowA (as intended).
It is missing steps 1,2,4 and 5
The code I have at the moment (called on button click)
Dim x As Integer '~~>Loop counter
Dim WS As Worksheet
Dim LastCellA As Range, LastCellB As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet2") '~~>Sheet with names
With WS
Set LastCellA = .Cells(.Rows.Count, "A").End(xlUp) '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
x = Application.WorksheetFunction.Max(LastCellA.Row)
End With
For numtimes = 1 To x
ActiveWorkbook.Sheets("Sheet1").Copy _
After:=ActiveWorkbook.Sheets(Worksheets.Count)
'~~>Copy values only
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Next
Still... I'm not sure of the point that you "Import" different values based on a drop down. That may be a different macro for loding the data. Then you need to call that macro instead of the .RefreshAll.
Sub test()
Dim uRow As Long, lRow As Long, i As Long
Dim wb As Workbook, ws As Object
With ThisWorkbook
Set ws = .Sheets("Sheet2")
With ws
uRow = .Cells(.Rows.Count, "A").End(xlUp).End(xlUp).Row
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set wb = Workbooks.Add
For i = uRow To lRow
.Sheets("Sheet1").Range("M1").Value = ws.Cells(i, 1).Value '<~~~ this should change the dropdown
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
For Each ws In wb.Sheets
ws.UsedRange.Value = ws.UsedRange.Value
Next
End With
End Sub
EDIT:
If you get trouble with the Sheet2 Column A List (cus it contains empty cells resulting of formulas) you may try a different approach:
Sub test()
Dim wb As Workbook, ws As Worksheet
Dim xVal As Variant
With ThisWorkbook
Set ws = .Sheets("Sheet2")
Set wb = Workbooks.Add
For Each xVal In Intersect(ws.Range("A:A"), ws.UsedRange).Value
If Len(xVal) Then
.Sheets("Sheet1").Range("M1").Value = xVal
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
wb.Sheets(wb.Sheets.Count).UsedRange.Value = wb.Sheets(wb.Sheets.Count).UsedRange.Value
End If
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
End With
End Sub
Based on the code you provided, I believe this is what you are looking for.
It will loop through your list, copy sheet1 to the new workbook and name the sheet.
I am not sure what you want with looping through your dropdown list.
Sub Button1_Click()
Dim wb As Workbook, Bk As Workbook
Dim WS As Worksheet, sh As Worksheet
Dim LastCellA As Long, LastCellB As Range, c As Range
Dim LastCellRowNumber As Long
Dim x As Integer '~~>Loop counter
Set wb = ThisWorkbook
Set WS = wb.Worksheets("Sheet2") '~~>Sheet with names
Set sh = wb.Sheets("Sheet1")
With WS
LastCellA = .Cells(.Rows.Count, "A").End(xlUp).Row '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
Set LastCellB = .Range("A1:A" & LastCellA).SpecialCells(xlCellTypeConstants, 23)
End With
Set Bk = Workbooks.Add
For Each c In LastCellB.Cells
sh.Range("M1") = c
sh.Copy After:=Bk.Sheets(Worksheets.Count)
With ActiveSheet
'~~>Copy values only
.UsedRange.Value = .UsedRange.Value
.Name = c
End With
Next c
End Sub

VBA - copy data from one worksheet t

Good morning,
I'm attempting to copy data from multiple worksheets (in cells M78:078) into one, where the name in the column (L) of the summary sheet matches to the worksheet name (pasting into columns Z:AA in the summary sheet.
At present the below code is erroring out:
Sub Output_data()
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ActiveSheet.Range("L:L").Value = wkSht.Name Then
ws.Range("M78:O78").Copy
ActiveSheet.Range("L").CurrentRegion.Copy Destination:=wkSht.Range("Z:AA").Paste
End If
Next ws
Application.ScreenUpdating = True
End Sub
Any help would be great.
DRod
Something like this should work for you. I commented the code in an attempt to explain what it does.
Sub Output_data()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsGet As Worksheet
Dim LCell As Range
Dim sDataCol As String
Dim lHeaderRow As Long
sDataCol = "L" 'Change to be the column you want to match sheet names agains
lHeaderRow = 1 'Change to be what your actual header row is
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Summary") 'Change this to be your Summary sheet
'Check for values in sDataCol
With ws.Range(sDataCol & lHeaderRow + 1, ws.Cells(ws.Rows.Count, sDataCol).End(xlUp))
If .Row <= lHeaderRow Then Exit Sub 'No data
'Loop through sDataCol values
For Each LCell In .Cells
'Check if sheet named that value exists
If Evaluate("ISREF('" & LCell.Text & "'!A1)") Then
'Found a matching sheet, copy M78:O78 to the corresponding row, column Z and on
Set wsGet = wb.Sheets(LCell.Text)
wsGet.Range("M78:O78").Copy ws.Cells(LCell.Row, "Z")
End If
Next LCell
End With
End Sub