buttonmaker0
12-04-2017, 02:15 PM
Hello All
Currently I have a macro that moves previous day remarks to current days report.
It is based of the assumption that the key number will always be in column
"C". How can I make it so that it do it no mater what column that key number is in?
Sub Get_oData()
Dim strrow As Integer 'Hold current row numner
Dim cntr As Integer 'hold true (1) or false(0)
Dim wb As Workbook
Dim p_day As String
Dim cBook As String 'current (newly downloaded) report
Dim nBook As String 'Prior report
Dim mBook As String 'Macro book
Dim ws As Integer 'Worksheet
Dim strCrow As Integer ' Hold the header row number for current(newly downloaded) report
Dim strLrowC As Integer ' Hold the last row number for current(newly downloaded) report
Dim strAWBcolC As String ' Hold the AWB column, coverted to letter for current(newly downloaded) report
Dim strRemarkcolC As String ' Hold the Advisor's Remarks column, coverted to letter for current(newly downloaded) report
Dim strCounter As Integer ' Hold the worksheet count
Dim strNrow As Integer ' Hold the header row number for prior report
Dim strLrowN As Integer ' Hold the last row number for prior report
Dim strAWBcolN As String ' Hold the AWB column, coverted to letter for prior report
Dim strRemarkcolN As String ' Hold the Advisor's Remarks column, coverted to letter for prior report
mBook = ActiveWorkbook.Name
MsgBox "Please select the Number of the newly downloaded sheet."
GetXLApp
cBook = ActiveWorkbook.Name
Range("A1").Select
' locate the header row of the current downloaded sheet
Do While cntr = 0
strrow = ActiveCell.Row
strCrow = WorksheetFunction.CountA(ActiveSheet.Range(strrow & ":" & strrow))
If strCrow < 5 Then
ActiveCell(2, 1).Select
End If
If Len(Range("D" & strrow)) <= 2 And ActiveCell.Row <= strrow Then
ActiveCell(2, 1).Select
End If
If strCrow > 5 Then
If Len(Range("D" & strrow)) > 2 Then
cntr = 1
End If
Else
cntr = 0
End If
Loop
strLrowC = ActiveSheet.UsedRange.Rows.Count
strCrow = ActiveCell.Row
strRemarkcolC = WorksheetFunction.VLookup(WorksheetFunction.Match("Advisor's Remarks", Range(strCrow & ":" & strCrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
strAWBcolC = WorksheetFunction.VLookup(WorksheetFunction.Match("AWB Number", ActiveSheet.Range(strCrow & ":" & strCrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
' go get the prior report used to get the comments from
Application.ScreenUpdating = False
MsgBox "Please select the location of your Last Report."
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
Path = .SelectedItems(1)
End If
End With
If Path = "" Then
MsgBox "Action Cancelled, program will end"
Exit Sub 'Hard Coded Path
Else
' user input path
End If
Workbooks.Open Filename:=Path
cntr = 0
strrow = 0
nBook = ActiveWorkbook.Name
strCounter = ActiveWorkbook.Worksheets.Count
For ws = 1 To strCounter
Sheets(ws).Select
Range("A1").Select
' locate the header row of the current downloaded sheet
Do While cntr = 0
strrow = ActiveCell.Row
strNrow = WorksheetFunction.CountA(ActiveSheet.Range(strrow & ":" & strrow))
If strCrow < 5 Then
ActiveCell(2, 1).Select
End If
If Len(Range("D" & strrow)) <= 2 And ActiveCell.Row <= strrow Then
ActiveCell(2, 1).Select
End If
If strCrow > 5 Then
If Len(Range("D" & strrow)) > 2 Then
cntr = 1
End If
Else
cntr = 0
End If
Loop
strLrowN = ActiveSheet.UsedRange.Rows.Count
strNrow = ActiveCell.Row
strRemarkcolN = WorksheetFunction.VLookup(WorksheetFunction.Match("Advisor's Remarks", Range(strNrow & ":" & strNrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
strAWBcolN = WorksheetFunction.VLookup(WorksheetFunction.Match("AWB Number", ActiveSheet.Range(strNrow & ":" & strNrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
Workbooks(cBook).Activate
Range(strRemarkcolC & strCrow).Select
strrow = ActiveCell.Row
Do While ActiveCell.Row < strLrowC
On Error Resume Next
check = WorksheetFunction.Match("Advisor's Remarks", Workbooks(nBook).Sheets("Sheet1").Range(strNrow & ":" & strNrow), 0) - 2
ActiveCell(2, 1).Select
strrow = strrow + 1
ActiveCell = WorksheetFunction.VLookup(ActiveSheet.Range(strAWBcolC & strrow), Workbooks(nBook).Sheets(ws).Range(strAWBcolN & strNrow & ":" & strRemarkcolN & strLrowN) _
, WorksheetFunction.Match("Advisor's Remarks", Workbooks(nBook).Sheets(ws).Range(strNrow & ":" & strNrow), 0) - 2, False)
Loop
Windows(nBook).Activate
Next ws
Workbooks(nBook).Close
MsgBox "Comments have been added."
Application.ScreenUpdating = True
End Sub
Sub test()
Dim strC As Integer
strC = WorksheetFunction.CountA(ActiveSheet.Range(Cells.Row & ":" & Cells.Row))
If strC = 1 Then
Exit Sub
End If
End Sub
Thanks in advance
Currently I have a macro that moves previous day remarks to current days report.
It is based of the assumption that the key number will always be in column
"C". How can I make it so that it do it no mater what column that key number is in?
Sub Get_oData()
Dim strrow As Integer 'Hold current row numner
Dim cntr As Integer 'hold true (1) or false(0)
Dim wb As Workbook
Dim p_day As String
Dim cBook As String 'current (newly downloaded) report
Dim nBook As String 'Prior report
Dim mBook As String 'Macro book
Dim ws As Integer 'Worksheet
Dim strCrow As Integer ' Hold the header row number for current(newly downloaded) report
Dim strLrowC As Integer ' Hold the last row number for current(newly downloaded) report
Dim strAWBcolC As String ' Hold the AWB column, coverted to letter for current(newly downloaded) report
Dim strRemarkcolC As String ' Hold the Advisor's Remarks column, coverted to letter for current(newly downloaded) report
Dim strCounter As Integer ' Hold the worksheet count
Dim strNrow As Integer ' Hold the header row number for prior report
Dim strLrowN As Integer ' Hold the last row number for prior report
Dim strAWBcolN As String ' Hold the AWB column, coverted to letter for prior report
Dim strRemarkcolN As String ' Hold the Advisor's Remarks column, coverted to letter for prior report
mBook = ActiveWorkbook.Name
MsgBox "Please select the Number of the newly downloaded sheet."
GetXLApp
cBook = ActiveWorkbook.Name
Range("A1").Select
' locate the header row of the current downloaded sheet
Do While cntr = 0
strrow = ActiveCell.Row
strCrow = WorksheetFunction.CountA(ActiveSheet.Range(strrow & ":" & strrow))
If strCrow < 5 Then
ActiveCell(2, 1).Select
End If
If Len(Range("D" & strrow)) <= 2 And ActiveCell.Row <= strrow Then
ActiveCell(2, 1).Select
End If
If strCrow > 5 Then
If Len(Range("D" & strrow)) > 2 Then
cntr = 1
End If
Else
cntr = 0
End If
Loop
strLrowC = ActiveSheet.UsedRange.Rows.Count
strCrow = ActiveCell.Row
strRemarkcolC = WorksheetFunction.VLookup(WorksheetFunction.Match("Advisor's Remarks", Range(strCrow & ":" & strCrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
strAWBcolC = WorksheetFunction.VLookup(WorksheetFunction.Match("AWB Number", ActiveSheet.Range(strCrow & ":" & strCrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
' go get the prior report used to get the comments from
Application.ScreenUpdating = False
MsgBox "Please select the location of your Last Report."
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
Path = .SelectedItems(1)
End If
End With
If Path = "" Then
MsgBox "Action Cancelled, program will end"
Exit Sub 'Hard Coded Path
Else
' user input path
End If
Workbooks.Open Filename:=Path
cntr = 0
strrow = 0
nBook = ActiveWorkbook.Name
strCounter = ActiveWorkbook.Worksheets.Count
For ws = 1 To strCounter
Sheets(ws).Select
Range("A1").Select
' locate the header row of the current downloaded sheet
Do While cntr = 0
strrow = ActiveCell.Row
strNrow = WorksheetFunction.CountA(ActiveSheet.Range(strrow & ":" & strrow))
If strCrow < 5 Then
ActiveCell(2, 1).Select
End If
If Len(Range("D" & strrow)) <= 2 And ActiveCell.Row <= strrow Then
ActiveCell(2, 1).Select
End If
If strCrow > 5 Then
If Len(Range("D" & strrow)) > 2 Then
cntr = 1
End If
Else
cntr = 0
End If
Loop
strLrowN = ActiveSheet.UsedRange.Rows.Count
strNrow = ActiveCell.Row
strRemarkcolN = WorksheetFunction.VLookup(WorksheetFunction.Match("Advisor's Remarks", Range(strNrow & ":" & strNrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
strAWBcolN = WorksheetFunction.VLookup(WorksheetFunction.Match("AWB Number", ActiveSheet.Range(strNrow & ":" & strNrow), 0), Workbooks(mBook).Sheets("Table").Range("B:C"), 2, False)
Workbooks(cBook).Activate
Range(strRemarkcolC & strCrow).Select
strrow = ActiveCell.Row
Do While ActiveCell.Row < strLrowC
On Error Resume Next
check = WorksheetFunction.Match("Advisor's Remarks", Workbooks(nBook).Sheets("Sheet1").Range(strNrow & ":" & strNrow), 0) - 2
ActiveCell(2, 1).Select
strrow = strrow + 1
ActiveCell = WorksheetFunction.VLookup(ActiveSheet.Range(strAWBcolC & strrow), Workbooks(nBook).Sheets(ws).Range(strAWBcolN & strNrow & ":" & strRemarkcolN & strLrowN) _
, WorksheetFunction.Match("Advisor's Remarks", Workbooks(nBook).Sheets(ws).Range(strNrow & ":" & strNrow), 0) - 2, False)
Loop
Windows(nBook).Activate
Next ws
Workbooks(nBook).Close
MsgBox "Comments have been added."
Application.ScreenUpdating = True
End Sub
Sub test()
Dim strC As Integer
strC = WorksheetFunction.CountA(ActiveSheet.Range(Cells.Row & ":" & Cells.Row))
If strC = 1 Then
Exit Sub
End If
End Sub
Thanks in advance