For various reasons, I need a macro that opens a separate workbook and pulls the cells from two different columns (D and I) that fit a criteria (contains a number), as well as the cell to the left of said number containing cell (C and H) and paste all of that into 2 columns (as opposed to 4) in a new workbook. C and H contain Text when next to a D or I column cell which contains a number. Cells in columns D and I can contain numbers, text or be blank. Then I need those to be pasted into the workbook that contians the macro into 2 columns (AT and AU) starting in cell AT2.
I have a dialogue box that prompts the user to select the workbook needed (as it will change several times throughout the year) for the source data. Where the code gets hung up is when at Set copyrng = (sell:selloff), it's giving me a syntax error. I wanna say that the issue is that I haven't "Set sell" to anything but I'm not sure what I need to set it to since it will not be a singular cell. I'm pretty new to VBA and have mostly been getting things off of the internet and adapting it to suit my needs.
I haven't been able to get the code to run so far due to the syntax error.
Dim Filename As String
Dim Sheet As Worksheet
Dim fldr As FileDialog
Dim Message As String: Message = "Would you like to import new data?"
Dim Ans
Ans = MsgBox(Message, vbYesNo)
Application.ScreenUpdating = False
If Ans = vbYes Then
Set fldr = Application.FileDialog(msoFileDialogFilePicker)
With fldr
.Title = "Select Current Data Sheet"
.Show
Dim FolderPath As String
If .SelectedItems.Count <> 0 Then
FolderPath = .SelectedItems(1)
Else
MsgBox "Please select a file, even if it's the old one. Otherwise, hit No on the first prompt"
End If
End With
FolderPath = fldr.SelectedItems(1)
Filename = Dir(FolderPath & "*.xlsx")
Dim UNdest As Variant
Dim sell As Range
Dim selloff As Range
Dim copyrng As Range
Dim dastination As Range
Set UNdest = Workbooks("Master Tracker").Sheets("Data").Range("AT2" & Rows.Count).End(xlUp).Offset(1)
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
Workbooks(Filename).Activate
For Each sell In Range("D:D")
If IsNumeric(sell.Value) Then
Set selloff = sell.Offset(-1, 0)
Set copyrng = (sell:selloff)
copyrng.Copy UNdest
Else 'should be skipping the cell if it doesn't contain a number
End If
Next sell
Workbooks(Filename).Close
Filename = Dir()
Loop
Else
End If
Application.ScreenUpdating = True
End Sub
Sorry if the code is messy or confusing. I have very little coding experience in general and have been trying to use VBA to make our operation run more smoothly. Therefore, I've been really copy pasting and modifying from different forums answering questions as opposed to trying to learn for comprehension. Hopefully, I'll get to that one day. Any help is appreciated. Thank you!
Main
Option Explicit
Sub ImportData()
Const PROC_TITLE As String = "Import Data"
Const INI_QUESTION As String = "Would you like to import new data?"
Const INI_CANCELED As String = "Operation canceled!"
Const FOLDER_TITLE As String = "Select Current Data Sheet"
Const FOLDER_CANCELED As String = "Folder dialog canceled!"
Const NO_FILES_FOUND As String = "No files found!"
Const SRC_FiLE_PATTERN As String = "*.xlsx"
Const SRC_SHEET_NAME As String = "Raw"
Const SRC_FIRST_ROW As Long = 2
Dim sCols() As Variant: sCols = VBA.Array("D", "C", "I", "H")
Const DST_SHEET_NAME As String = "Data"
Const DST_FIRST_ROW As Long = 2
Dim dCols() As Variant: dCols = VBA.Array("AT", "AU")
Dim Answer As Long:
Answer = MsgBox(INI_QUESTION, vbYesNo + vbQuestion, PROC_TITLE)
If Answer = vbNo Then
MsgBox INI_CANCELED, vbExclamation, PROC_TITLE
Exit Sub
End If
Dim FolderPath As String:
FolderPath = PickFolder(, FOLDER_TITLE, , FOLDER_CANCELED)
If Len(FolderPath) = 0 Then Exit Sub
Dim Filename As String: Filename = Dir(FolderPath & SRC_FiLE_PATTERN)
If Len(Filename) = 0 Then
MsgBox NO_FILES_FOUND, vbExclamation, PROC_TITLE
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Sheets(DST_SHEET_NAME)
Dim dcell As Range: Set dcell = dws.Cells(DST_FIRST_ROW, dCols(0))
Dim dUpper As Long: dUpper = UBound(dCols)
Dim sUpper As Long: sUpper = UBound(sCols)
Application.ScreenUpdating = False
Dim n As Long
For n = 0 To dUpper
dcell.EntireRow.Columns(dCols(n)) _
.Resize(dws.Rows.Count - DST_FIRST_ROW + 1).ClearContents
Next n
Dim swb As Workbook, sws As Worksheet, srg As Range, scell As Range
Dim Data1() As Variant, Data2() As Variant
Dim srCount As Long, sr As Long, dr As Long
Dim IsSheetFound As Boolean, IsDataFound As Boolean, WasCleared As Boolean
Do While Len(Filename) > 0
Set swb = Workbooks.Open( _
Filename:=FolderPath & Filename, ReadOnly:=True)
On Error Resume Next
Set sws = swb.Sheets(SRC_SHEET_NAME)
On Error GoTo 0
IsSheetFound = Not sws Is Nothing
If IsSheetFound Then
IsSheetFound = False ' reset
With sws.Cells(SRC_FIRST_ROW, sCols(0))
srCount = sws.Cells(sws.Rows.Count, .Column) _
.End(xlUp).Row - .Row + 1
If srCount > 0 Then
Set srg = .Resize(srCount)
IsDataFound = True
End If
End With
End If
If IsDataFound Then
IsDataFound = False ' reset
For n = 0 To sUpper Step dUpper + 1
Set srg = srg.EntireRow.Columns(sCols(n))
dr = 0 ' reset
Data1 = GetRangeSingleColumn(srg)
Data2 = GetRangeSingleColumn(srg.EntireRow _
.Columns(sCols(n + 1)))
For sr = 1 To srCount
If VarType(Data1(sr, 1)) = vbDouble Then
dr = dr + 1
Data1(dr, 1) = Data1(sr, 1) ' number
Data2(dr, 1) = Data2(sr, 1) ' string
End If
Next sr
If dr > 0 Then
dcell.Resize(dr).Value = Data1
dcell.EntireRow.Columns(dCols(1)).Resize(dr).Value = Data2
Set dcell = dcell.Offset(dr)
End If
Next n
End If
Set sws = Nothing ' reset
swb.Close SaveChanges:=False
Filename = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation
End Sub
Help
Function PickFolder( _
Optional ByVal InitialFolderPath As String = "", _
Optional ByVal DialogTitle As String = "Browse", _
Optional ByVal DialogButtonName As String = "OK", _
Optional ByVal CancelMessage As String = "") _
As String
Const PROC_TITLE As String = "Pick Folder"
With Application.FileDialog(4) ' 4 = msoFileDialogFolderPicker
.Title = DialogTitle
.ButtonName = DialogButtonName
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String
If Len(InitialFolderPath) > 0 Then
FolderPath = InitialFolderPath
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
.InitialFileName = FolderPath
End If
If .Show Then
FolderPath = .SelectedItems(1)
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
PickFolder = FolderPath
Else
If Len(CancelMessage) > 0 Then
MsgBox CancelMessage, vbExclamation, PROC_TITLE
End If
End If
End With
End Function
Function GetRangeSingleColumn( _
ByVal singleRange As Range, _
Optional ByVal ColumnIndex As Long = 1) _
As Variant
If singleRange Is Nothing Then Exit Function
If ColumnIndex < 1 Then Exit Function
If ColumnIndex > singleRange.Columns.Count Then Exit Function
Dim Data() As Variant
With singleRange.Columns(ColumnIndex)
If .Rows.Count = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
Else
Data = .Value
End If
End With
GetRangeSingleColumn = Data
End Function