Hi I have a problem with a macro which copies information from one workbook and paste it into another. Then it creates two columns and fill them with an IF formula to compare two dates. Those formulas bring the wrong result as one of the columns have another date format, and I can't change it, whatever I do on the cell is not working, only if I erase the value on any cell of that column and write a date I can change the format.
The main format needed is YYYY-MM-DD, but this column is set as dd/mm/yyyy, even if I update the cell and set it as date or custom it doesn't work at all, it keeps showing the wrong format.
This is the macro I work on, is there any way to solve this issue?
Thank you in advance.
Sub AD_Audit()
'Last cell in column
Dim ws As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Dim wb3 As Workbook
Set ws = Worksheets(2)
With ws
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
Dim Wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set Wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set selectedworkbook
Set wb2 = ActiveWorkbook
'Select cells to copy
wb2.Worksheets(2).Range("A1:BD" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).Select
Selection.Copy
'Go back to original workbook you want to paste into
Wb.Activate
'Paste starting at the last empty row
Wb.Worksheets(2).Activate
Wb.Worksheets(2).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
Dim LstrDate As String
Dim LDate As Date
LstrDate = "Apr 6, 2003"
LDate = CDate(LstrDate)
'search for columns containing the data needed
Dim x As Integer
Dim lastRow As Long
lastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rFind As Range
With Range("A:DB")
Set rFind = .Find(What:="Account Last Updated", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
End If
End With
Dim rFind1 As Range
With Range("A:DB")
Set rFind1 = .Find(What:="Termination Date", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind1 Is Nothing Then
End If
End With
Dim rFind2 As Range
With Range("A:DB")
Set rFind2 = .Find(What:="Last Password set date", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind2 Is Nothing Then
End If
End With
'create columns and fill them with formulas
x = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, x + 1) = "Account last updated after termination"
intcounter = 2
While (intcounter <= lastRow)
ActiveSheet.Cells(intcounter, x + 1).Formula = "=IF(TEXT(""" & Cells(intcounter, rFind.Column) & """,""YYYY/MM/DD"")>=TEXT(""" & Cells(intcounter, rFind1.Column) & """,""YYYY/MM/DD""),""review"",""disabled"")"
intcounter = intcounter + 1
Wend
x = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, x + 1) = "Password After Termination"
intcounter = 2
While (intcounter <= lastRow)
ActiveSheet.Cells(intcounter, x + 1).Formula = "=IF(TEXT(""" & Cells(intcounter, rFind2.Column) & """,""YYYY/MM/DD"")>=TEXT(""" & Cells(intcounter, rFind1.Column) & """,""YYYY/MM/DD""),""review"",""old"")"
intcounter = intcounter + 1
Wend
'add column Actions
Worksheets(2).Range("A1").EntireColumn.Insert
Worksheets(2).Range("A1").Formula = "Actions"
'Set headers to bold text
Rows(1).Font.Bold = True
'check for filter, turn on if none exists
If Not ActiveSheet.AutoFilterMode Then
ActiveSheet.Range("A1:BD1").AutoFilter
End If
Dim Notes As Object, Maildb As Object, workspace As Object, UIdoc As Object, UserName As String
Dim MailDbName As String
ThisWorkbook.Activate
For Each Wb In Workbooks
If Not (Wb Is ActiveWorkbook) Then Wb.Close savechanges:=False
Next
End Sub
Date values are stored in a worksheet cell as a numerical value so different formats can be applied to different cells and still retain the ability to compare (or add, subtract, etc). The formula you're applied to each cell is forcing a comparison in a specific text format when the actual value.
The key is to set your formula up to use the address of the cell, not the cell contents.
So your cell formula can simply be:
ActiveSheet.Cells(intcounter, x + 1).Formula = "=If(" & Cells(intcounter, rFind.Column).Address & ">=" & Cells(intcounter, rFind1.Column).Address & ","""review""","""disabled""")"
Related
I have searched high and low and have tested many VB scripts but havent found a solution to this. the below is the data I have
Data
Need to have an output like below
result
the VB code I am using
Option Explicit
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorkbook(strStart, strEnd)
End Sub
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbkOutput As Workbook
Dim wksOutput As Worksheet, wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
lngDateCol = 3 '<~ we know dates are in column C
Set wbkOutput = Workbooks.Add
'Loop through each worksheet
For Each wks In ThisWorkbook.Worksheets
With wks
'Create a new worksheet in the output workbook
Set wksOutput = wbkOutput.Sheets.Add
wksOutput.Name = wks.Name
'Create a destination range on the new worksheet that we
'will copy our filtered data to
Set rngTarget = wksOutput.Cells(1, 1)
'Identify the data range on this sheet for the autofilter step
'by finding the last row and the last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
'Apply a filter to the full range to get only rows that
'are in between the input dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'Copy only the visible cells and paste to the
'new worksheet in our output workbook
Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
rngResult.Copy Destination:=rngTarget
End With
'Clear the autofilter safely
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
Next wks
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
but when data is like below the result doesnt show two rows with different time, any help would be much appreciated please.
Data 3
rgds
thanks for sharing your code. I think it looks a bit more than what you need. Going off your example, if everything is formatted as such, this would be your solution:
Option Explicit
Sub SplitDateTime()
Dim mydate As String, mytime As String, mytime2 As String, i As Long, sht As Worksheet, lastrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Change headers
Range("H1:H" & lastrow).Value = Range("G1:G" & lastrow).Value
Range("G1:G" & lastrow).Value = Range("F1:F" & lastrow).Value
Range("D1").Value = "Date"
Range("E1").Value = "C/In"
Range("F1").Value = "C/Out"
'Move values around
For i = 2 To lastrow Step 2
mydate = DateValue(Range("D" & i).Value)
mytime = TimeValue(Range("D" & i).Value)
mytime2 = TimeValue(Range("D" & i + 1).Value)
Range("D" & i).Value = mydate
Range("E" & i).Value = mytime
Range("F" & i).Value = mytime2
Next i
'Delete excess rows
For i = lastrow To 2 Step -2
Range("A" & i).EntireRow.Delete
Next i
'Regrab lastrow value
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Change date format
Range("D2:D" & lastrow).NumberFormat = "m/d/yyyy"
End Sub
Currently have the following code:
Sub StartReport()
**Dim Month As String**
Dim Data_sht As Worksheet
Dim Pivot_sht As Worksheet
Dim StartPoint As Range
Dim DataRange As Range
Dim PivotName As String
Dim NewRange As String
' Set variables equal to data sheet and pivot sheet
**Set Month = "B2"**
Set Data_sht = ThisWorkbook.Worksheets.**Month**
Set Pivot_sht = ThisWorkbook.Worksheets("Controller Report")
'Enter in Pivot table name
PivotName = "PivotTable1"
'Dynamically retrieve range address of data
Set StartPoint = Data_sht.Range("A1")
Set DataRange = Data_sht.Range(StartPoint, StartPoint.SpecialCells(xlLastCell))
NewRange = Data_sht.Name & "!" & _
DataRange.Address(ReferenceStyle:=x1R1C1)
'make sure every column in data set has a heading and is not blank (error prevention)
If WorksheetFunction.CountBlank(DataRange.Rows(1)) > 0 Then
MsgBox "One of your data columsn has a blank heading." & vbNewLine _
& "please fix and re-run!.", vbCritical, "Column heading Missing!"
Exit Sub
End If
'Change pivot table data source range address
Pivot_sht.PivotTables(PivotName).ChangePivotCache _
ThisWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=NewRange)
'Ensure pivot table is refreashed
Pivot_sht.PivotTables("PivotTable1").RefreshTable
'Complete Message
MsgBox PivotName & " 's data source range has been successfully updated!"
End Sub
The parts which are bolded (have ** before and after them) are where i am having difficulty.
I want the data to be picked up from a drop down menu I have created, that has the names of all the tabs on them.
The drop down is located in cell "B2" on the first tab. When a month is selected from this dropdown, i want the datasheet with the same name to be selected as the data source for the pivot tables.
Please help
Detailed code and comments in the code below:
Option Explicit
Sub StartReport()
Dim PvtTbl As PivotTable
Dim myMonth As String
Dim Data_sht As Worksheet
Dim Pivot_sht As Worksheet
Dim StartPoint As Range
Dim DataRange As Range
Dim PivotName As String
Dim NewRange As String
Dim LastCol As Long
Dim LastRow As Long
' Set variables equal to data sheet and pivot sheet
myMonth = ThisWorkbook.Sheets("Sheet1").Range("B2").Value2 ' <-- modify "Sheet1" to your sheet where you have the Drop-Down
' set the worksheet object according to the month selected
Set Data_sht = ThisWorkbook.Worksheets(myMonth)
Set Pivot_sht = ThisWorkbook.Worksheets("Controller Report")
'Enter in Pivot table name
PivotName = "PivotTable1"
' set the Pivot-Table object
Set PvtTbl = Pivot_sht.PivotTables(PivotName)
'Dynamically retrieve range address of data === Modified ===
With Data_sht
LastRow = FindLastRow(Data_sht)
LastCol = FindLastCol(Data_sht)
Set DataRange = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
NewRange = DataRange.Address(False, False, xlA1, xlExternal)
'make sure every column in data set has a heading and is not blank (error prevention)
If WorksheetFunction.CountA(DataRange.Rows(1)) < DataRange.Columns.Count Then
MsgBox "One of your data columns has a blank heading." & vbNewLine _
& "please fix and re-run!.", vbCritical, "Column heading Missing!"
Exit Sub
End If
'Change pivot table data source range address
PvtTbl.ChangePivotCache ThisWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=NewRange)
'Ensure pivot table is refreashed
PvtTbl.RefreshTable
'Complete Message
MsgBox PivotName & " 's data source range has been successfully updated!"
End Sub
Function FindLastCol(sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
End If
End With
End Function
Function FindLastRow(sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.Row
Else
MsgBox "Error! worksheet is empty", vbCritical
End If
End With
End Function
How do I compare a mapping table (values in different cells) in excel and map the value of that header to my main database.
Main Database:
Mapping Table:
Tanu's Sheet:
It should map the headers(wgt, ht, bmi, etc) of the file (tanu, sweety, Raju) and compare it with main database and replace it with the headers of main database
The code written so far
Sub SelectColumn()
Dim xColIndex As Integer
Dim xRowIndex As Integer
xIndex = Application.ActiveCell.Column
xRowIndex = Application.ActiveSheet.Cells(Rows.Count,
xIndex).End(xlUp).Row
Range(Cells(2, xIndex), Cells(xRowIndex, xIndex)).Select
End Sub
Can't get through
This code will check your mapping table and replace headers in each of their Sheets for each workbook tanu, sweety and etc, (it will look for the headers in the range A1:Z1000, change this if you need it to be a bigger range):
Sub foo3()
Dim Wbook As Workbook
Dim wSheet As Worksheet
Dim wb As ThisWorkbook
Set wb = ThisWorkbook
Application.DisplayAlerts = False
LastCol = wb.Sheets("LMal").Cells(1, Columns.Count).End(xlToLeft).Column 'Check how many columns in the Mapping Table
LastRow = wb.Sheets("LMal").Cells(Rows.Count, "A").End(xlUp).Row 'Check how many rows in the Mapping Table
For i = 2 To LastCol
Filename = "C:\Users\tanu\Desktop\" & wb.Sheets("LMal").Cells(1, i) & ".xlsx" ' Get the Sheet name such as tanu, sweety, etc
Set Wbook = Workbooks.Open(Filename)
For x = 2 To LastRow ' loop through rows
Search = wb.Sheets("LMal").Cells(x, i).Value
On Error Resume Next
For Each wSheet In Wbook.Worksheets
Set strGotIt = wSheet.Cells.Find(What:=Search, After:=wSheet.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
If strGotIt <> vbNullString Then
wSheet.Cells(strGotIt.Row, strGotIt.Column).Value = wb.Sheets("LMal").Cells(x, 1).Value 'replace the value in tanu's sheet
On Error GoTo 0
End If
Next
On Error GoTo 0
Next x
Wbook.Close SaveChanges:=True
Application.DisplayAlerts = True
Next i
End Sub
I have maintained two Excel reports EPC1.xlsx and Control Power Transformers.xlsm respectively.
I want to trigger an button click from Control Power Transformers.xlsm report where it will search for "CTPT" term in "A" column from EPC1.xlsx, once it finds the term it need to copy Column B and Column c till the row ends (in EPC1.xlsx) and paste it in Control Power Transformers.xlsm workbook
I am successful in retrieving the cell address of "CTPT" term but how to select the data from adjacent column B and C?
And this is what I have tried
Private Sub CommandButton23_Click()
Dim rngX As Range
Dim num As String
Windows("EPC 1.xlsx").Activate
Set rngX = Worksheets("Sheet1").Range("A1:A10000").Find("CTPT", Lookat:=xlPart)
num = rngX.Address ' Here we will the get the cell address of CTPT ($A$14)
Range(rngX, Range("C" & rngX.Row).End(xlDown)).Copy
Windows("Control Power Transformers.xlsm").Activate
Sheets("Sheet2").Select
ActiveSheet.Range("E2").PasteSpecial (xlPasteValues)
End Sub
Paste the below in sample workbook. The below code will help to select both files using file dialog. It will search for word "CTPT". if so it will copy the column values from CTPT sheet to control file.
Sub DetailsFilePath()
Dim File1 As String
Dim File2 As String
Dim findtext As String
Dim copyvalues As Long
Dim c As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
MsgBox "Open the CTPT file"
Application.FileDialog(msoFileDialogFilePicker).Show
'On Error Resume Next
' open the file
File1 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
MsgBox "Open the Control Power Transformers file"
Application.FileDialog(msoFileDialogFilePicker).Show
File2 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
Set wb1 = Workbooks.Open(Filename:=File1)
Set ws1 = wb1.Worksheets("sheet1")
Set wb2 = Workbooks.Open(Filename:=File2)
Set ws2 = wb2.Worksheets("sheet1")
findtext = "CTPT"
With ws1.Columns(1)
Set c = .Find(findtext, LookIn:=xlValues)
If Not c Is Nothing Then
copyvalues = c.Column
ws2.Columns(2).Value = ws1.Columns(2).Value
ws2.Columns(3).Value = ws1.Columns(3).Value
End If
End With
wb1.Close savechanges:=True
wb2.Close savechanges:=True
End Sub
You need to use FindNext to find other results, and the Offset will help you select what you want from the address of your results :
Sub test_Karthik()
Dim WbEPC As Workbook, _
WbCPT As Workbook, _
WsEPC As Worksheet, _
WsCPT As Worksheet, _
FirstAddress As String, _
WriteRow As Long, _
cF As Range, _
num As String
Set WbEPC = Workbooks("EPC 1.xlsx")
Set WbCPT = Workbooks("Control Power Transformers.xlsm")
Set WsEPC = WbEPC.Sheets("Sheet1")
Set WsCPT = WbCPT.Sheets("Sheet2")
With WsEPC
.Activate
With .Range("A1:A10000")
'First, define properly the Find method
Set cF = .Find(What:="CTPT", _
After:=ActiveCell, _
LookIn:=xlValues, _
Lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'If there is a result, keep looking with FindNext method
If Not cF Is Nothing Then
FirstAddress = cF.Address
Do
num = cF.Address ' Here we will the get the cell address of CTPT ($A$14)
WsEPC.Range(cF.Offset(0, 1), cF.Offset(0, 2).End(xlDown)).Copy
WriteRow = WsCPT.Range("E" & WsCPT.Rows.count).End(xlUp).Row + 1
WsCPT.Range("E" & WriteRow).PasteSpecial (xlPasteValues)
Set cF = .FindNext(cF)
'Look until you find again the first result
Loop While Not cF Is Nothing And cF.Address <> FirstAddress
End If
End With
End With
End Sub
I have a working VBA macro which copies from one spreadsheet 'AverageEarnings' to another 'Sheet1', under the condition that Column AO has the word 'UNGRADED' in it. The macro copies the entirety of these conditional rows to Sheet1. I am looking to copy columns B and C ('AverageEarnings') to columns A and B ('Sheet1'). How do I amend this.
Sub UngradedToSHEET1()
' UngradedToSHEET1 Macro
'
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim stringToFind As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("AverageEarnings")
stringToFind = "UNGRADED"
With ws1
'Remove all filters from spreadsheet to prevent loss of information.
.AutoFilterMode = False
lRow = .Range("AO" & .Rows.Count).End(xlUp).Row 'Find a specific column.
With .Range("AO1:AO" & lRow) ' This is the row where GRADED or UNGRADED is specified.
.AutoFilter Field:=1, Criteria1:="=*" & stringToFind & "*" 'Filter specific information.
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'Remove spreadsheet filters again.
.AutoFilterMode = False
End With
Set ws2 = wb1.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then ' Find a blank row after A1.
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
End Sub
This line copies the entire row:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
You will need to change EntireRow to just copy the columns you want, probably something like:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Range(.Cells(1,2),.Cells(1,3))
Hope this helps, I can't check this right now.